Objects for ANS Forth FLAME BAIT! 
Author Message
 Objects for ANS Forth FLAME BAIT!

TZ> I think it may be
TZ> fun to talk about all this stuff in a theoretical way, but there is
TZ> already a concrete
TZ> implementation
TZ> on the table.  Why dont' some of the other experts on this subject
TZ> submit a suitable implementation for examination.

Please slowly, Tom, slowly. :)

I wrote only two mails for this. First input was a response to a query about
techniques making SOM/CORBA efforts usable. My point: The same story as before
- 'neutral' interfaces are 'C' interfaces.

Second input brought in an example. The ratio system / application writing is
here for sure better than 1:5 (took alone for my ANS implementation). My point
there was clear as well: Don't enforce full packets. Put some reflection upon
what happens and how it is related to Forth. Make it usable, not an exhibition
object. This is not easy, as Forth by itself is tightly related to OO stuff.

For further investigation, look at the following. This has been posted in
c.l.f. some while before (maybe, anyone here will remember it). Sorry for
having edited the code; it had to fit into blocks plus shadow blocks, as well
it survived some experimental use. Appended is some elementary approach for
making use of it.

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

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.


Applied Physics Laboratory  Johns Hopkins University

\ Object Oriented Programming System, Version 3.1,
\ dpANS (October, 1991)

hex
\ 2 9 thru
\ decimal

                                        hex
: STRUCTURE ( -- pfa template)          create here 0 , 0

: AUS:      ( offset size --- offset')  create over , +

: CHARS:    chars aus: ;
: CHAR:     1 chars: ;
: CELLS:    cells >R aligned R> aus: ;
: CELL:     1 cells: ;
: STRUCT:   >R aligned R> aus: ;

: ENDSTRUCTURE   ( pfa template --)  aligned swap ! ;
: MAKESTRUCT     ( size --)          create allot ;

\ 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


\ Define messages accepted by a particular class hierarchy.

: MESSAGES>   ( -- addr[nmsgs] nmsgs)
   create here 0 dup ,

: ENDMESSAGES>  swap ! ;

: MSG:     ( n -- n')
   create dup cells class-structure + , 1+
   does>   ( object --)
           over current-object



           R>   current-object ! ;

\ Define class hierarchy constructors.

variable CURRENT-CLASS

: PUSH-VOCABS  ( <order> class -- <order>')

: DEFAULT-METHOD  ( --)
   ." method undefined" abort ;

\ Define class hierarchy constructors.

: CONSTRUCT-CLASS  ( nmsgs size-of-object parent --)
   wordlist
   create here dup >R current-class !
   class-structure allot


   0 do ['] default-method  , loop

   over set-current set-order ;

\ Define class hierarchy constructors.

: CLASS>  ( nmsgs --)
   0 0 construct-class ;

: SUB-CLASS>  ( class --)



: END>  ( --)


   drop over set-current set-order ;

\ Local variables

variable TO?
: TO:  true to? ! ; immediate

: LOCAL:  ( --)


   does>  ( addr[offset] --)

                 postpone self+


\ Methods

: GET-BODY   ( -- x)

: SUPER  ( --)

: METHOD:  ( -- addr[slot] xt colon-sys)

: ;METHOD   ( addr[slot] xt colon-sys --)
   postpone ; swap ! ; immediate

: NEW   ( class -- object)

------------------------------------------------------------------------ (
shadow blocks follow)

\ 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.

\ Object Oriented Programming System, Version 3.1,
\ dpANS (October, 1991)

\ 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 of class

: STRUCTURE  \ Start structure declaration.

: AUS:       \ Structure member compiler.
   does>     \ Add member's offset to base.

: CHARS:     \ Create n char member.
: CHAR:      \ Create 1 char member.
: CELLS:     \ Create n cell member.
: CELL:      \ Create 1 cell member.
: STRUCT:    \ Create member of given size.

: ENDSTRUCTURE
: MAKESTRUCT \ allocate memory for a struct of given size

\ 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    \ Copy current object to parameter stack.
: SELF+   \ Index instance variable.

\ Define class hierarchy constructors.

: MESSAGES>
   does>
: ENDMESSAGES>

: MSG:     \ Create message n.
   does>   \ Call method n for given object.
           \ save current object
           \ set new current object
           \ fetch vector from class and execute
           \ restore original 'current' object



      R> current-object ! ;

\ Define class hierarchy constructors.

variable CURRENT-CLASS  \ class currently being defined

: PUSH-VOCABS
   \ Add any parent wordlists to the search order on the stack
   \ then add the wordlist belonging to the given class.

: DEFAULT-METHOD
   \ This is executed if an object receives a message
   \ for which there is no defined method.

\ Define class hierarchy constructors.

: CONSTRUCT-CLASS
   \ build a class data structure with the given parameters,
   \ fill with null execution vectors, create naming wordlist,
   \ and modify search order.
   \ create wordlist
   \ name class; record address
   \ allocate class structure
   \ fill in wordlist, parent
   \ fill in size and number of msgs
   \ fill in default methods
   \ defs in new wordlist

\ Define class hierarchy constructors.

: CLASS>  \ Create a new class hiearchy.

: SUB-CLASS>
   \ Create a subclass of the given class.
   \ The subclass inherits the parents' methods and instance
   \ variables.

: END>
   \ Complete class definition by restoring search order.

\ Local variables

variable TO?
: TO  true to? ! ; immediate

: LOCAL:
          \ Create an instance variable for current class.

   does>  \ Compile fetch or store of instance.

\ Methods

: GET-BODY  \ Look up the next word in the input stream, and
            \ extract its body.  It must have been 'create'd.

: SUPER     \ Convert the next message to the self object
            \ into a subroutine call.

: METHOD:   \ Define a method to correspond with message
            \ indicated in input stream.

: ;METHOD   \ Complete compilation of method.
            \ Allocate an object of type class.
            \ allot object + class pointer

: NEW       \ init class pointer

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

The following is a minimum approach for using the above code. Watch for late
binding techniques at the end, by use of vectorizing, set objects' class
field.

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

\           2 11 thru

messages> mm1
msg: init
msg: show
msg: m3
endmessages>

mm1 class> cc1

local: ll1
local: ll2
local: ll3

method: init to: ll3 to: ll2 to: ll1                  ;method

method: show   ll3     ll2     ll1 . . . ." /cc1 "  ;method

method: m3 ." m3 " ;method

end>

cc1 sub-class> cs1

local: ll4

method: init      to: ll4 super init    ;method

method: show   ." s:" ll4 super show .  ;method

method: m3 ." m3c " ;method

end>

mm1 class> cc2

local: ll1
local: ll2
local: ll3

method: init to: ll3 to: ll2 to: ll1                  ;method

method: show    ll3     ll2     ll1 . . .  ." /cc2 " ;method

 method: m3 ." m3 " ;method

end>

cc1 sub-class> cs2

local: ll4

method: init to: ll4 super init    ;method

method: show     ll4 super show .  ;method

method: m3 ." m3c " ;method

end>

mm1 class> cc3

local: ll1
local: ll2
local: ll3

method: init to: ll3 to: ll2 to: ll1                 ;method

method: show    ll3     ll2     ll1 . . .  ." /cc3" ;method

method: m3 ." m3 " ;method

end>

cc1 sub-class> cs3

local: ll4

method: init to: ll4 super init    ;method

method: show     ll4 super show .  ;method

method: m3 ." m3c " ;method

end>

cc1 new constant o1
cc2 new constant o2
cc3 new constant o3

cs1 new constant o4
cs2 new constant o5
cs3 new constant o6

 4  5  6      o1 init
14 15 16      o2 init
24 25 26      o3 init
34 35 36 37   o4 init
44 45 46 47   o5 init
54 55 56 57   o6 init

o1 show
o2 show
o3 show
o4 show
o5 show
o6 show

cc1 new constant ox

: XX
   cc1 ox !  24 25 26  ox init ox show
   cc2 ox !  24 25 26  ox init ox show
   cc3 ox !  24 25 26  ox init ox show ;

: XY
   ox !  24 25 26  ox init ox show ;

cc1 xy
cc2 xy
cc3 xy

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

Yes, have fun with it :)



Wed, 10 Feb 1999 03:00:00 GMT  
 
 [ 1 post ] 

 Relevant Pages 

1. Window Systems and Forth (was: Mac vs PC FLAME BAIT Par EXELENCE)

2. Interesting, Was: Mac vs PC FLAME BAIT Par EXELENCE

3. FLAME BAIT!

4. G.C as disqualifier (Flame-Bait)

5. GC as disqualifier (Flame-Bait)

6. Not really a flame-bait

7. Warning: Flame Bait

8. Microsoft Flame Bait

9. ANS Forth in ANS Forth?

10. Announcing Ficl 2.0: ANS Forth with Objects

11. Algol-Style Syntax (Was: Objects for ANS Forth)

12. Objects for ANS Forth

 

 
Powered by phpBB® Forum Software