Object-Oriented Forth

This page documents a conversation with Mitch Bradley in my attempt to understand the following piece of Forth code, which implements a namespaced object-oriented forth package called OOF. This is the implementation from GForth; there's a little bit of description at in the GForth manual section describing OOF. See also this discussion of late- and early-binding OO in Forth.

oof.fs, from gforth

\ oof.fs	Object Oriented FORTH
\ 		This file is (c) 1996,2000 by Bernd Paysan
\			e-mail: bernd.paysan@gmx.de
\
\		Please copy and share this program, modify it for your system
\		and improve it as you like. But don't remove this notice.
\
\		Thank you.
\

\  The program uses the following words
\  from CORE :
\  decimal : bl word 0= ; = cells Constant Variable ! Create , allot @
\  IF POSTPONE >r ELSE +! dup + THEN immediate r> * >body cell+
\  Literal drop align here aligned DOES> execute ['] 2@ recurse swap
\  1+ over LOOP and EXIT ?dup 0< ] [ rot r@ - i negate +LOOP 2drop
\  BEGIN WHILE 2dup REPEAT 1- rshift > / ' move UNTIL or count
\  from CORE-EXT :
\  nip false Value tuck true ?DO compile, erase pick :noname 0<> 
\  from BLOCK-EXT :
\  \ 
\  from EXCEPTION :
\  throw 
\  from EXCEPTION-EXT :
\  abort" 
\  from FILE :
\  ( S" 
\  from FLOAT :
\  faligned 
\  from LOCAL :
\  TO 
\  from MEMORY :
\  allocate free 
\  from SEARCH :
\  find definitions get-order set-order get-current wordlist
\  set-current search-wordlist
\  from SEARCH-EXT :
\  also Forth previous 
\  from STRING :
\  /string compare 
\  from TOOLS-EXT :
\  [IF] [THEN] [ELSE] state 
\  from non-ANS :
\  cell dummy [THEN] ?EXIT Vocabulary [ELSE] ( \G 

\ Loadscreen                                           27dec95py

decimal

: define?  ( -- flag )
  bl word find  nip 0= ;

define? cell  [IF]
1 cells Constant cell
[THEN]

define? \G [IF]
: \G postpone \ ; immediate
[THEN]

define? ?EXIT [IF]
: ?EXIT  postpone IF  postpone EXIT postpone THEN ; immediate
[THEN]

define? Vocabulary [IF]
: Vocabulary wordlist create ,
DOES> @ >r get-order nip r> swap set-order ;
[THEN]

define? faligned [IF] false [ELSE] 1 faligned 8 = [THEN]
[IF]
: 8aligned ( n1 -- n2 )  faligned ;
[ELSE]
: 8aligned ( n1 -- n2 )  7 + -8 and ;
[THEN]

Vocabulary Objects  also Objects also definitions

Vocabulary types  types also

0 cells Constant :wordlist
1 cells Constant :parent
2 cells Constant :child
3 cells Constant :next
4 cells Constant :method#
5 cells Constant :var#
6 cells Constant :newlink
7 cells Constant :iface
8 cells Constant :init

0 cells Constant :inext
1 cells Constant :ilist
2 cells Constant :ilen
3 cells Constant :inum

Variable op
: op! ( o -- )  op ! ;

Forth definitions

Create ostack 0 , 16 cells allot

: ^ ( -- o )  op @ ;
: o@ ( -- o )  op @ @ ;
: >o ( o -- )
    state @
    IF    postpone ^ postpone >r postpone op!
    ELSE  1 ostack +! ^ ostack dup @ cells + ! op!
    THEN  ; immediate
: o> ( -- )
    state @
    IF    postpone r> postpone op!
    ELSE  ostack dup @ cells + @ op! -1 ostack +!
    THEN  ; immediate
: o[] ( n -- ) o@ :var# + @ * ^ + op! ;

Objects definitions

\ Coding                                               27dec95py

0 Constant #static
1 Constant #method
2 Constant #early
3 Constant #var
4 Constant #defer

: exec?    ( addr -- flag )
  >body cell+ @ #method = ;
: static?  ( addr -- flag )
  >body cell+ @ #static = ;
: early?   ( addr -- flag )
  >body cell+ @ #early  = ;
: defer?   ( addr -- flag )
  >body cell+ @ #defer  = ;

false Value oset?

: o+,   ( addr offset -- )
  postpone Literal postpone ^ postpone +
  oset? IF  postpone op!  ELSE  postpone >o  THEN  drop ;
: o*,   ( addr offset -- )
  postpone Literal postpone * postpone Literal postpone +
  oset? IF  postpone op!  ELSE  postpone >o  THEN ;
: ^+@  ( offset -- addr )  ^ + @ ;
: o+@,  ( addr offset -- )
    postpone Literal postpone ^+@  oset? IF  postpone op!  ELSE  postpone >o  THEN drop ;
: ^*@  ( offset -- addr )  ^ + @ tuck @ :var# + @ 8aligned * + ;
: o+@*, ( addr offset -- )
  postpone Literal postpone ^*@  oset? IF  postpone op!  ELSE  postpone >o  THEN drop ;

\ variables / memory allocation                        30oct94py

Variable lastob
Variable lastparent   0 lastparent !
Variable vars
Variable methods
Variable decl  0 decl !
Variable 'link

: crash  true abort" unbound method" ;

: link, ( addr -- ) align here 'link !  , 0 , 0 , ;

0 link,

\ type declaration                                     30oct94py

: vallot ( size -- offset )  vars @ >r  dup vars +!
    'link @ 0=
    IF  lastparent @ dup IF  :newlink + @  THEN  link,
    THEN
    'link @ 2 cells + +! r> ;

: valign  ( -- )  vars @ aligned vars ! ;
define? faligned 0= [IF]
: vfalign ( -- )  vars @ faligned vars ! ;
[THEN]

: mallot ( -- offset )    methods @ cell methods +! ;

types definitions

: static   ( -- ) \ oof- oof
    \G Create a class-wide cell-sized variable.
    mallot Create , #static ,
DOES> @ o@ + ;
: method   ( -- ) \ oof- oof
    \G Create a method selector.
    mallot Create , #method ,
DOES> @ o@ + @ execute ;
: early    ( -- ) \ oof- oof
    \G Create a method selector for early binding.
    Create ['] crash , #early ,
DOES> @ execute ;
: var ( size -- ) \ oof- oof
    \G Create an instance variable
    vallot Create , #var ,
DOES> @ ^ + ;
: defer    ( -- ) \ oof- oof
    \G Create an instance defer
    valign cell vallot Create , #defer ,
DOES> @ ^ + @ execute ;

\ dealing with threads                                 29oct94py

Objects definitions

: object-order ( wid0 .. widm m addr -- wid0 .. widn n )
    dup  IF  2@ >r recurse r> swap 1+  ELSE  drop  THEN ;

: interface-order ( wid0 .. widm m addr -- wid0 .. widn n )
    dup  IF    2@ >r recurse r> :ilist + @ swap 1+
         ELSE  drop  THEN ;

: add-order ( addr -- n )  dup 0= ?EXIT  >r
    get-order r> swap >r 0 swap
    dup >r object-order r> :iface + @ interface-order
    r> over >r + set-order r> ;

: drop-order ( n -- )  0 ?DO  previous  LOOP ;

\ object compiling/executing                           20feb95py

: o, ( xt early? -- )
  over exec?   over and  IF 
      drop >body @ o@ + @ compile,  EXIT  THEN
  over static? over and  IF 
      drop >body @ o@ + @ postpone Literal  EXIT THEN
  drop dup early?  IF >body @  THEN  compile, ;

: findo    ( string -- cfa n )
    o@ add-order >r
    find
    ?dup 0= IF drop set-order true abort" method not found!" THEN
    r> drop-order ;

false Value method?

: method,  ( object early? -- )  true to method?
    swap >o >r bl word  findo  0< state @ and
    IF  r> o,  ELSE  r> drop execute  THEN  o> false to method?  ;

: cmethod,  ( object early? -- )
    state @ dup >r
    0= IF  postpone ]  THEN
    method,
    r> 0= IF  postpone [  THEN ;

: early, ( object -- )  true to oset?  true  method,
  state @ oset? and IF  postpone o>  THEN  false to oset? ;
: late,  ( object -- )  true to oset?  false method,
  state @ oset? and IF  postpone o>  THEN  false to oset? ;

\ new,                                                 29oct94py

previous Objects definitions

Variable alloc
0 Value ohere

: oallot ( n -- )  ohere + to ohere ;

: ((new, ( link -- )
  dup @ ?dup IF  recurse  THEN   cell+ 2@ swap ohere + >r
  ?dup IF  ohere >r dup >r :newlink + @ recurse r> r> !  THEN
  r> to ohere ;

: (new  ( object -- )
  ohere >r dup >r :newlink + @ ((new, r> r> ! ;

: init-instance ( pos link -- pos )
    dup >r @ ?dup IF  recurse  THEN  r> cell+ 2@
    IF  drop dup >r ^ +
        >o o@ :init + @ execute  0 o@ :newlink + @ recurse o>
        r> THEN + ;

: init-object ( object -- size )
    >o o@ :init + @ execute  0 o@ :newlink + @ init-instance o> ;

: (new, ( object -- ) ohere dup >r over :var# + @ erase (new
    r> init-object drop ;

: size@  ( objc -- size )  :var# + @ 8aligned ;
: (new[],   ( n o -- addr ) ohere >r
    dup size@ rot over * oallot r@ ohere dup >r 2 pick -
    ?DO  I to ohere >r dup >r (new, r> r> dup negate +LOOP
    2drop r> to ohere r> ;

\ new,                                                 29oct94py

Create chunks here 16 cells dup allot erase

: DelFix ( addr root -- ) dup @ 2 pick ! ! ;

: NewFix  ( root size # -- addr )
  BEGIN  2 pick @ ?dup 0=
  WHILE  2dup * allocate throw over 0
         ?DO    dup 4 pick DelFix 2 pick +
         LOOP
         drop
  REPEAT
  >r drop r@ @ rot ! r@ swap erase r> ;

: >chunk ( n -- root n' )
  1- -8 and dup 3 rshift cells chunks + swap 8 + ;

: Dalloc ( size -- addr )
  dup 128 > IF  allocate throw EXIT  THEN
  >chunk 2048 over / NewFix ;

: Salloc ( size -- addr ) align here swap allot ;

: dispose, ( addr size -- )
    dup 128 > IF drop free throw EXIT THEN
    >chunk drop DelFix ;

: new, ( o -- addr )  dup :var# + @
  alloc @ execute dup >r to ohere (new, r> ;

: new[], ( n o -- addr )  dup :var# + @ 8aligned
  2 pick * alloc @ execute to ohere (new[], ;

Forth definitions

: dynamic ['] Dalloc alloc ! ;  dynamic
: static  ['] Salloc alloc ! ;

Objects definitions

\ instance creation                                    29mar94py

: instance, ( o -- )  alloc @ >r static new, r> alloc ! drop
  DOES> state @ IF  dup postpone Literal oset? IF  postpone op!  ELSE  postpone >o  THEN  THEN early,
;
: ptr,      ( o -- )  0 , ,
  DOES>  state @
    IF    dup postpone Literal postpone @ oset? IF  postpone op!  ELSE  postpone >o  THEN cell+
    ELSE  @  THEN late, ;

: array,  ( n o -- )  alloc @ >r static new[], r> alloc ! drop
    DOES> ( n -- ) dup dup @ size@
          state @ IF  o*,  ELSE  nip rot * +  THEN  early, ;

\ class creation                                       29mar94py

Variable voc#
Variable classlist
Variable old-current
Variable ob-interface

: voc! ( addr -- )  get-current old-current !
  add-order  2 + voc# !
  get-order wordlist tuck classlist ! 1+ set-order
  also types classlist @ set-current ;

: (class-does>  DOES> false method, ;

: (class ( parent -- )  (class-does>
    here lastob !  true decl !  0 ob-interface !
    0 ,  dup voc!  dup lastparent !
  dup 0= IF  0  ELSE  :method# + 2@  THEN  methods ! vars ! ;

: (is ( addr -- )  bl word findo drop
    dup defer? abort" not deferred!"
    >body @ state @
    IF    postpone ^ postpone Literal postpone + postpone !
    ELSE  ^ + !  THEN ;

: inherit   ( -- )  bl word findo drop
    dup exec?  IF  >body @ dup o@ + @ swap lastob @ + !  EXIT  THEN
    abort" Not a polymorph method!" ;

\ instance variables inside objects                    27dec93py

: instvar,    ( addr -- ) dup , here 0 , 0 vallot swap !
    'link @ 2 cells + @  IF  'link @ link,  THEN
    'link @ >r dup r@ cell+ ! :var# + @ dup vars +! r> 2 cells + !
    DOES>  dup 2@ swap state @ IF  o+,  ELSE  ^ + nip nip  THEN
           early, ;

: instptr>  ( -- )  DOES>  dup 2@ swap
    state @ IF  o+@,  ELSE  ^ + @ nip nip  THEN  late, ;

: instptr,    ( addr -- )  , here 0 , cell vallot swap !
    instptr> ;

: (o* ( i addr -- addr' ) dup @ :var# + @ 8aligned rot * + ;

: instarray,  ( addr -- )  , here 0 , cell vallot swap !
    DOES>  dup 2@ swap
           state @  IF  o+@*,  ELSE  ^ + @ nip nip (o*  THEN
           late, ;

\ bind instance pointers                               27mar94py

: ((link ( addr -- o addr' ) 2@ swap ^ + ;

: (link  ( -- o addr )  bl word findo drop >body state @
    IF postpone Literal postpone ((link EXIT THEN ((link ;

: parent? ( class o -- class class' ) @
  BEGIN  2dup = ?EXIT dup  WHILE  :parent + @  REPEAT ;

: (bound ( obj1 obj2 adr2 -- ) >r over parent?
    nip 0= abort" not the same class !" r> ! ;

: (bind ( addr -- ) \ <name>
    (link state @ IF postpone (bound EXIT THEN (bound ;

: (sbound ( o addr -- ) dup cell+ @ swap (bound ;

Forth definitions

: bind ( o -- )  '  state @
  IF   postpone Literal postpone >body postpone (sbound EXIT  THEN
  >body (sbound ;  immediate

Objects definitions

\ method implementation                                29oct94py

Variable m-name
Variable last-interface  0 last-interface !

: interface, ( -- )  last-interface @
    BEGIN  dup  WHILE  dup , @  REPEAT drop ;

: inter, ( iface -- )
    align here over :inum + @ lastob @ + !
    here over :ilen + @ dup allot move ;

: interfaces, ( -- ) ob-interface @ lastob @ :iface + !
    ob-interface @
    BEGIN  dup  WHILE  2@ inter,  REPEAT  drop ;

: lastob!  ( -- )  lastob @ dup
    BEGIN  nip dup @ here cell+ 2 pick ! dup 0= UNTIL  drop
    dup , op! o@ lastob ! ;

: thread,  ( -- )  classlist @ , ;
: var,     ( -- )  methods @ , vars @ , ;
: parent,  ( -- o parent )
    o@ lastparent @ 2dup dup , 0 ,
    dup IF  :child + dup @ , !   ELSE  , drop  THEN ;
: 'link,  ( -- )
    'link @ ?dup 0=
    IF  lastparent @ dup  IF  :newlink + @  THEN  THEN , ;
: cells,  ( -- )
  methods @ :init ?DO  ['] crash , cell +LOOP ;

\ method implementation                                20feb95py

types definitions

: how:  ( -- ) \ oof- oof how-to
\G End declaration, start implementation
    decl @ 0= abort" not twice!" 0 decl !
    align  interface,
    lastob! thread, parent, var, 'link, 0 , cells, interfaces,
    dup
    IF    dup :method# + @ >r :init + swap r> :init /string move
    ELSE  2drop  THEN ;

: class; ( -- ) \ oof- oof end-class
\G End class declaration or implementation
    decl @ IF  how:  THEN  0 'link !
    voc# @ drop-order old-current @ set-current ;

: ptr ( -- ) \ oof- oof
    \G Create an instance pointer
    Create immediate lastob @ here lastob ! instptr, ;
: asptr ( class -- ) \ oof- oof
    \G Create an alias to an instance pointer, cast to another class.
    cell+ @ Create immediate
    lastob @ here lastob ! , ,  instptr> ;

: Fpostpone  postpone postpone ; immediate

: : ( <methodname> -- ) \ oof- oof colon
    decl @ abort" HOW: missing! "
    bl word findo 0= abort" not found"
    dup exec? over early? or over >body cell+ @ 0< or
    0= abort" not a method"
    m-name ! :noname ;

Forth

: ; ( xt colon-sys -- ) \ oof- oof
    postpone ;
    m-name @ dup >body swap exec?
    IF    @ o@ +
    ELSE  dup cell+ @ 0< IF  2@ swap o@ + @ +  THEN
    THEN ! ; immediate

Forth definitions

\ object                                               23mar95py

Create object  immediate  0 (class \ do not create as subclass
         cell var  oblink       \ create offset for backlink
         static    thread       \ method/variable wordlist
         static    parento      \ pointer to parent
         static    childo       \ ptr to first child
         static    nexto        \ ptr to next child of parent
         static    method#      \ number of methods (bytes)
         static    size         \ number of variables (bytes)
	 static    newlink      \ ptr to allocated space
	 static    ilist        \ interface list
	 method    init ( ... -- ) \ object- oof
         method    dispose ( -- ) \ object- oof

         early     class ( "name" -- ) \ object- oof
	 early     new ( -- o ) \ object- oof
	 			immediate
	 early     new[] ( n -- o ) \ object- oof new-array
				immediate
         early     : ( "name" -- ) \ object- oof define
         early     ptr ( "name" -- ) \ object- oof
         early     asptr ( o "name" -- ) \ object- oof
         early     [] ( n "name" -- ) \ object- oof array
	 early     ::  ( "name" -- ) \ object- oof scope
	 			immediate
         early     class? ( o -- flag ) \ object- oof class-query
	 early     super  ( "name" -- ) \ object- oof
				immediate
         early     self ( -- o ) \ object- oof
	 early     bind ( o "name" -- ) \ object- oof
				immediate
         early     bound ( class addr "name" -- ) \ object- oof
	 early     link ( "name" -- class addr ) \ object- oof
				immediate
	 early     is  ( xt "name" -- ) \ object- oof
				immediate
	 early     send ( xt -- ) \ object- oof
				immediate
	 early     with ( o -- ) \ object- oof
				immediate
	 early     endwith ( -- ) \ object- oof
				immediate
	 early     ' ( "name" -- xt ) \ object- oof tick
				immediate
	 early     postpone ( "name" -- ) \ object- oof
				immediate
	 early     definitions ( -- ) \ object- oof
	 
\ base object class implementation part                23mar95py

how:
0 parento !
0 childo !
0 nexto !
    : class   ( -- )       Create immediate o@ (class ;
    : :       ( -- )       Create immediate o@
	decl @ IF  instvar,    ELSE  instance,  THEN ;
    : ptr     ( -- )       Create immediate o@
	decl @ IF  instptr,    ELSE  ptr,       THEN ;
    : asptr   ( addr -- )
	decl @ 0= abort" only in declaration!"
	Create immediate o@ , cell+ @ , instptr> ;
    : []      ( n -- )     Create immediate o@
	decl @ IF  instarray,  ELSE  array,     THEN ;
    : new     ( -- o )     o@ state @
	IF  Fpostpone Literal Fpostpone new,  ELSE  new,  THEN ;
    : new[]   ( n -- o )   o@ state @
	IF Fpostpone Literal Fpostpone new[], ELSE new[], THEN ;
    : dispose ( -- )       ^ size @ dispose, ;
    : bind    ( addr -- )  (bind ;
    : bound   ( o1 o2 addr2  -- ) (bound ;
    : link    ( -- o addr ) (link ;
    : class?  ( class -- flag )  ^ parent? nip 0<> ;
    : ::      ( -- )
	state @ IF  ^ true method,  ELSE  inherit  THEN ;
    : super   ( -- )       parento true method, ;
    : is      ( cfa -- )   (is ;
    : self    ( -- obj )   ^ ;
    : init    ( -- )       ;
    
    : '       ( -- xt )  bl word findo 0= abort" not found!"
	state @ IF  Fpostpone Literal  THEN ;
    : send    ( xt -- )  execute ;
    : postpone ( -- )  o@ add-order Fpostpone Fpostpone drop-order ;
    
    : with ( -- )
	state @ oset? 0= and IF  Fpostpone >o  THEN
	o@ add-order voc# ! false to oset? ;
    : endwith  Fpostpone o> voc# @ drop-order ;

    : definitions
	o@ add-order 1+ voc# ! also types o@ lastob !
	false to oset?   get-current old-current !
	thread @ set-current ;
class; \ object

\ interface                                            01sep96py

Objects definitions

: implement ( interface -- ) \ oof-interface- oof
    align here over , ob-interface @ , ob-interface !
    :ilist + @ >r get-order r> swap 1+ set-order  1 voc# +! ;

: inter-method, ( interface -- ) \ oof-interface- oof
    :ilist + @ bl word count 2dup s" '" str=
    dup >r IF  2drop bl word count  THEN
    rot search-wordlist
    dup 0= abort" Not an interface method!"
    r> IF  drop state @ IF  postpone Literal  THEN  EXIT  THEN
    0< state @ and  IF  compile,  ELSE  execute  THEN ;

Variable inter-list
Variable lastif
Variable inter#

Vocabulary interfaces  interfaces definitions

: method  ( -- ) \ oof-interface- oof
    mallot Create , inter# @ ,
DOES> 2@ swap o@ + @ + @ execute ;

: how: ( -- ) \ oof-interface- oof
    align
    here lastif @ !  0 decl !
    here  last-interface @ ,  last-interface !
    inter-list @ ,  methods @ ,  inter# @ ,
    methods @ :inum cell+ ?DO  ['] crash ,  LOOP ;

: interface; ( -- ) \ oof-interface- oof
    old-current @ set-current
    previous previous ;

: : ( <methodname> -- ) \ oof-interface- oof colon
    decl @ abort" HOW: missing! "
    bl word count lastif @ @ :ilist + @
    search-wordlist 0= abort" not found"
    dup >body cell+ @ 0< 0= abort" not a method"
    m-name ! :noname ;

Forth

: ; ( xt colon-sys -- ) \ oof-interface- oof
  postpone ;
  m-name @ >body @ lastif @ @ + ! ; immediate

Forth definitions

: interface-does>
    DOES>  @ decl @  IF  implement  ELSE  inter-method,  THEN ;
: interface ( -- ) \ oof-interface- oof
    Create  interface-does>
    here lastif !  0 ,  get-current old-current !
    last-interface @ dup  IF  :inum @  THEN  1 cells - inter# !
    get-order wordlist
    dup inter-list ! dup set-current swap 1+ set-order
    true decl !
    0 vars ! :inum cell+ methods !  also interfaces ;

previous previous

Discussion transcript

• cscott: http://pastebin.com/qGtzgwhE is the oof.fs source, which apparently implements namespacing for object methods, but it's a little opaque to me
• Quozl: (the mixed case hurts my sensibilities ;-)
• cscott: i assume that the definition for 'obj' would could call input parser to lookahead to get the method name, and then lookup the method name in the object's vocabulary, but i'm lost looking at the code
• MitchBradley: which line is the definition for obj on?
• Quozl: it would take me a long time to parse oof.fs ... and i can't find an " obj " either, is there sample of use?
• cscott: http://www.delorie.com/gnu/docs/gforth/gforth_173.html
• cscott: at the very bottom of that page, "You can only invoke a selector if the receiving object belongs to the class where the selector was defined or one of its descendents; e.g., you can invoke draw only for objects belonging to graphical or its descendents (e.g., circle). The scoping mechanism will check if you try to invoke a selector that is not defined in this class hierarchy, so you'll get an error at compilation time."
• cscott: that's the part I'm trying to figure out how it's implemented
• MitchBradley: add-order and findo
• MitchBradley: lines 216 and 232
• MitchBradley: cscott: I think findo is the key. method, uses it, and various words used method, to resolve and compile inherited method references
• MitchBradley: all the "state @ if" stuff is to handle the distinction between interactive use and compilation
• cscott: yeah, i agree that findo is doing the method lookup; i'm still trying to grok where exactly the method is invoked
• cscott: probably i'm not understanding the "state @ if" stuff
• MitchBradley: state @ if <how to handle the reference in compile state> else <what to do in interactive interpretation state> then
• MitchBradley: method, either executes the word (" r> drop execute") or compiles it ("r> o,")
• cscott: ok. so (looking at the example in the gforth manual) if I execute '50 circle : my-circle' that gives me a word 'my-circle' in the dictionary. When I execute '100 100 my-circle draw' when I get to the 'my-circle' in the line, where am i exactly?
• MitchBradley: it will take me a few to dig through; please stand by
• cscott: somewhere in 'o,' (lines 225-230)?
• cscott: oh, hm, looks like there's method of object named 'send', so that "100 100 my-circle ' draw my-circle send" would be equivalent to "100 100 my-circle draw"
• MitchBradley: quite likely
• cscott: i still haven't figured out exactly where "my circle" futzes with the active vocabulary, but ' and send are defined in likes 579 and 581 in a pretty straightforward way
• cscott: the hard work being done by ' which invokes findo, as you pointed out before; then send just needs to execute that word; presumably the "object context" (whatever that is) has already been set up for the send method.
• MitchBradley: The overloading of ":" makes it difficult to work out what is going on...
• cscott: yes, and the fact that there's bits executed at compile time and at run-time, and in "declaring the class" and "defining the implementation" modes.
• MitchBradley: I think how: (line 456) may be important
• cscott: i thought so, then i convinced myself that that just changed the parsing state from "declaring the class" to "defining the implementation" and that what I was really looking for was object instantiation stuff
• cscott: graphical class circle \ "graphical" is the parent class
• cscott: cell var circle-radius
• cscott: how:
• cscott:  : draw ( x y -- )
• cscott: circle-radius @ draw-circle ;
• cscott:  : init ( n-radius -- (
• cscott: circle-radius ! ;
• cscott: class;
• cscott: so i think all 'how' is doing is redefining : and friends so that they make proper method declarations for the circle class
• cscott: (and checking that you don't have two 'how:' words in a single class)
• cscott: really what I should do is fire up gforth, execute '50 circle : my-circle' and then 'see my-circle'
• MitchBradley: "op" seems to refer to the current object
• MitchBradley: I think that activating an object sets op via op!
• MitchBradley: and that in turn affects pretty much everything else via o@
• cscott: so i fired up gforth. 'see my-circle' reports:
• cscott: create my-circle
• cscott: DOES> useraddr <64> @
• cscott: IF dup POSTPONE Literal oset?
• cscott: IF -1223034368 compile,
• cscott: ELSE POSTPONE >o
• cscott: THEN
• cscott: THEN
• cscott: early, ; immediate
• MitchBradley: okay, that is the does? clause for instance,
• MitchBradley: s/does?/does>/
• dogi left the room (quit: Ping timeout: 480 seconds).
• MitchBradley: confirming my suspicion about op! being key
• MitchBradley: >o pushes object references on a stack
• cscott: : foo 100 100 my-circle draw ; see foo
• cscott: : foo
• cscott: 100 100 -1223017680 ^ >r op! <-1223017768> r> op! ;
• cscott: so there's your op! again
• MitchBradley: that is very similar to how OFW $call-method works
• cscott: I haven't quite understood where the vocabulary is being altered
• MitchBradley: the vocabulary is not being altered
• MitchBradley: the vocabulary is used at compile time
• MitchBradley: this is an early bound object
• cscott: so is that the "compile," reference in "see my-circle" ?
• cscott: i think i need to better understand early binding in forth
• MitchBradley: "-1223034368 compile," is how the decompiler renders the source expression "postpone op!"
• cscott: where ' op! would give -1223034368, presumably?
• MitchBradley: yeah, the number is probably the xt value for op!
• MitchBradley: look at the definition of ">o"
• cscott: so, vocabularies are used for late binding -- where does the lookup for early binding happen?
• MitchBradley: It includes "postpone ^ postpone >r postpone op!"
• MitchBradley: vocabularies are used for the lookup for early binding too
• MitchBradley: once the lookup is complete, the result is bound inside the new definition
• MitchBradley: the binding takes the form:
• MitchBradley: <instance-ref> ^ >r op! <method> r> op!
• MitchBradley: which is pushing the old instance on the return stack, switching the instance context to the new instance, executing the method in that context, and then popping the return stack to restore the previous instance context
• MitchBradley: OFW method calls work exactly the same way, without all the syntactic sugar
• cscott: i like the syntactic sugar, i just don't understand how it works yet ;-)
• MitchBradley: line 555
• cscott: i'm expecting to find ['] somewhere to parse the next word in the input (the method name) and then call findo on it to look it up, and then emit that in the output of the compiler
• MitchBradley: bl word find
• MitchBradley: line 241
• MitchBradley: line 482
• cscott: what does 'bl' do?
• MitchBradley: pushes the ascii code for the space character
• cscott: 'word' parses the next word from the input then?
• MitchBradley: bl word parses a blank-delimited token
• MitchBradley: I would have used the newer form "parse-word", but "bl word" is possibly slightly more portable
• MitchBradley: lots of ancient history I'd rather not go into...
• cscott: ok, so i'm chugging along parsing "100 100 my-circle draw". When I get to "my-circle" i'm executing some code from the instance, word around line 333, right?
• MitchBradley: The canonical phrase used by the non-oof Forth interpreter is "bl word find"
• MitchBradley: yes, my-circle executes the does> clause of instance,
• cscott: and because i'm in compile state, i'm executing the "dup postpone Literal oset? IF postpone op! ELSE postpone >o THEN" part, followed by a call to "early," ?
• MitchBradley: since you are in interpret state at that point, it executes the ">o" branch, pushing the "my-circle" instance on the interpret state object stack
• MitchBradley: you are not in compile state
• MitchBradley: You would be in compile state if you had said  : draw-me 100 100 my-circle draw  ;
• cscott: hm, ok. either way i end up in early, which after some other stuff invokes method, which eventually does the "bl word findo" that I was looking for
• cscott: if i was in compile state, i wouldn't actually have an object reference yet, but i still would have ended up in early, and then in method, looking up "draw" in an appropriate class (via some early binding magic)
• MitchBradley: presumably, yes
• cscott: in my traditional static types world, i'd say that we know the type of 'my-circle' even though we don't know its value yet, and so we look up 'draw' based on the type
• cscott: something similar is happening in the early binding world, without the meta-mechanism of static types
• MitchBradley: I'll take your word for it
• cscott: i wish i could spend a couple of days and really grok all the early-binding magic i'm glossing over
• cscott: what I think is happening is that the *class* 'circle' is early-bound, and so the compilation-mode stuff is passing around references to the class value, even though 'my-circle' is a runtime value which is not yet defined. but i'm guessing.
• MitchBradley: I have to go to town now
• cscott: o is the class, and op is the object? findo deals with o@ not op!
• cscott: MitchBradley: thanks again for your wizardry
• cscott: i need to get back to nacl porting anyway
• MitchBradley: everything is much easier if you just dispense with the sugar
• cjb: don't let Walter hear
• MitchBradley: The only sugar I might add is the word "the", so that instead of saying "also class-name methodname previous", you could instead say "the class-name method-name"
• MitchBradley: e.g. "the circle draw"
• MitchBradley: tip-o-the-hat to Robert Berkey for "the"
• cscott: MitchBradley: that makes sense. I can't let all of the (say) GTK namespace into the main forth dictionary, it's too huge; but "someobj the gtk label show" might be reasonable.