Since SWOOP has been in the sftalk discussion lately I thought it'd make
sense to post this. I use SWOOP in my personal project and have come across
several issues that I've had to work around. I also added some features
that I wanted, like the ability to reference objects dynamically beyond
locals. I'll paste my code at the bottom. Transcripts of 2 files; the SWOOP
extensions rely on another file that provides some basic conveniences and
custom stuff. I couldn't be bothered to package it up more neatly. ;)
Would be nice to see SWOOP improved a bit in the distribution. Currently it
still seems a bit shaky.

1.) You can't access a member of another object of the class you're
currently defining. The object will get compiled and then the member will
be compiled on SELF. There must be a way to make SWOOP smart enough to
notice that you are trying to call a member on another object, not SELF.
2.) No static members - words that are part of a class's vocabulary - to do
this you'd need to make classes objects, I think. Not crucial, but I've
often found myself wishing for it.
3.) Passing objects around is not straightforward. If you leave an object
naked, words in part of the class you're editing for some reason are out of
search order. I made a shorthand for END-REFERENCE called &, that resets
the search order to where it should be. So my code has to be peppered with
&'s right now.
4.) Seems that most of the time, I can't call external DLL functions from
inside a class unless I use ::. It's a minor nuisance, but I can't figure
out why it crops up now and then.

I also have a feature wishlist that I wanted to share with the mailing list.
 Should these make sense, I think they'd make strong additions to
SwiftForth:

6.) Ability to SEE and LOCATE class members - extend those words to detect
if the next word is a class and then if the following word is a member of it
and then expose that.
7.) Instead of defining members inside a CLASS...END-CLASS structure,
ability to use an alternate notation with the class in front of every
member; this would make it easier to try arbitrary things out dynamically in
the IDE.

Back to my code, it has one caveat that I know of; the syntax setting class
REF's is unpredictable and awkward. The phrase "OBJECT & SELF TO REF" sets
SELF REF to OBJECT. So it's a little weird to read. This is something that
I know needs improvement.

Cheers,

-Roger

--- Forthext.f

{
   Forth extensions - Roger Levy - Version 0.1

   DEFS[ ]DEFS
      <wordlist> defs[ ... ]defs - convenient syntax to define wordlists
}

wordlist constant local-objects
: defs[ get-current swap set-current ;
: ]defs set-current ;

aka negate minus

\ -- Low-level extensions --

: u+ rot + swap ;

\ Stack extensions

: nips 0 do nip loop ;
: reverse 1+ 1 max 1 ?do i 1- roll loop ;

\ Dictionary extensions

: w, here w! 2 allot ;

\ Memory access extensions

: 2h! dup >r 2 + h! r> h! ;
: c@+ dup c@ 1 u+ ;

{
: w@+ ( addr -- addr+2 n )
  dup w@ 2 u+ ;
}
icode w@+ ( addr -- a+2 n )
   PUSH(EBX) \ save addr on stack
   0 [EBX] EBX MOVZXW \ read value from addr to tos
   2 # 0 [EBP] ADD \ increment address
   RET END-CODE

: w!+ ( addr n -- addr+2 )
  over w! 2 + ;

aka w!+ h!+

icode h@+ ( addr -- a+2 n )
   PUSH(EBX) \ save addr on stack
   0 [EBX] EBX MOVSXW \ read value from addr to tos
   2 # 0 [EBP] ADD \ increment address
   RET END-CODE

icode 2h@
   ebx eax mov
   0 [eax] ebx movsxw
   push(ebx)
   2 [eax] ebx movsxw
   ret end-code

ICODE h+! ( n addr -- )
   0 [EBP] EAX MOV
   16bit: eax 0 [EBX] ADD
   4 [EBP] EBX MOV
   8 # EBP ADD
   RET END-CODE

\ Math extensions

: m+! dup >r 2@ rot m+ r> 2! ;
: u+ swap >r + r> ;

\ works with negative n so long as it's not less than -range
: wrap ( n u-start u-range -- n )
>r swap over - r> swap over 2* + swap mod + ;

-? : $cd ( path& len -- )
   pad zplace pad SetCurrentDirectory 0= abort" invalid directory" ;

\ String extensions

aka s" " immediate

: tabs>spaces 2dup 0 do dup c@ 9 = if bl over c! then 1 + loop drop ;

: <>"" c@ ;

: string: create 256 /allot ;

---- Swoopext.f

optional swoopext
{ Extensions to SWOOP - Roger Levy - 0.1
   [[ ]] - convenient locals
      inside the double brackets, you can use these symbols:
      <class> * <name> - create a local temporary object
      <class> : <name> - caste a passed stack item as a local object
   REF - references
      <class> ref <name> - when used inside of class definitions you can
have a reference that is part of a class.
      <ref> - will fetch the referenced object
      <object> to <ref> - will point the reference to something
      <object1> <object2> to <ref> - example of setting <object2>'s
reference to <object1>
   CREATES - lets you build an object using dictionary operators.
      After CREATES, you must completely fill the object with ',' etc, or
you'll have memory leaks!
   SKIP - allocate unnamed bytes in a class.
   & - when referencing an embeded or referenced object, that namespace is
not automatically removed if the next word is not a method of that object.
      this symbol forcibly sets the current class being defined to be the
current namespace.
      basically it allows the object to be placed on the stack without
executing any of its methods.
   OBJECT - to be used along with LAST to get the last compiled object.
      LAST OBJECT
   BUILDS is extended to execute CINIT (a deferred member of SUPREME) on the
created object.
}

only forth definitions

variable obj

local-objects defs[
   : * bl parse s" makes " 1 obj +! ;
   : : bl parse s" names " 1 obj +! ;
]defs

: [[
   0 obj !
   local-objects +order postpone [objects
   ; immediate

: ]]
   obj @ 0 do pad place pad append pad count ( 2dup type ) evaluate loop
   objects] local-objects -order ;

\ -- References --

icode >ref
   3 CELLS 5 + [EDI] [EBX] EBX LEA
   0 [ebx] ebx mov
   ret end-code

\ : >ref
\ 5 + 3 cells + .s @ ;

\ Ref
oop open-package
public

: &
   end-reference ; immediate

: ref ( class -- )
   create-xt , immediate objtag , , 0 ,
   does> ['] >ref (object) ;

: >ref! >data ! ;
: >ref+! >data +! ;

: (to-ref) ( xt -- )
   end-reference
   state @ if postpone literal postpone >ref! exit then >ref! ;

: to-ref ( -- flag ) >in @ >r '
   dup >body cell+ @ objtag = if (to-ref) r> drop true
   else drop r> >in ! false then ;

: (+to-ref) ( xt -- )
   end-reference
   state @ if postpone literal postpone >ref+! exit then >ref+! ;

: +to-ref ( -- flag ) >in @ >r '
   dup >body cell+ @ objtag = if (+to-ref) r> drop true
   else drop r> >in ! false then ;

: (&of-ref) ( xt -- )
   end-reference
   state @ if postpone literal postpone >data exit then >data ;

: &of-ref ( -- flag ) >in @ >r '
   dup >body cell+ @ objtag = if (&of-ref) r> drop true
   else drop r> >in ! false then ;

flavor a-ref same-as is-undefined

: compile-ref ( 'data -- ) "self" \ 'data: offset
   2@ ?DUP IF POSTPONE LITERAL POSTPONE + THEN postpone @ >THIS +MEMBERS ;
{
   @+ ( member) postpone literal postpone + postpone @
   end-reference @ ( class) >this +members ;
}

: run-ref ( object 'data -- addr ) dup cell+ @ >this +members
   @ + @ ;

a-ref

>compile-xt <will-be compile-ref
>runtime-xt <will-be run-ref
>ccompile-xt <will-be compile-ref

GET-CURRENT ( *) CC-WORDS SET-CURRENT

   : ref ( class -- )
      member this sizeof
      a-ref create-flavored ( class) ,
      cell this >size +! ;

   : skip ( bytes -- )
       this >size +! ;

   : ; end-reference [ CC-WORDS +ORDER ] postpone ; [ CC-WORDS -ORDER ] ;
immediate

GET-CURRENT CC-WORDS <> THROW ( *) SET-CURRENT

: (to-cref) ( xt -- )
   end-reference
>body 5 cells + @
   state @ if postpone literal postpone + postpone ! exit then
   + ! ;

: to-cref ( -- flag ) >in @ >r '
   dup >body cell+ @ ['] a-ref = if (to-cref) r> drop true
   else drop r> >in ! false then ;

-? : TO ( n -- )
   LOBJ-COMP TO-LOCAL ?EXIT \ local object
   LVAR-COMP TO-LOCAL ?EXIT \ local variable
             to-cref ?exit \ class ref
             to-ref ?EXIT \ ref
             TO-VALUE ?EXIT \ VALUE
   1 'METHOD ! ; IMMEDIATE \ SINGLE

: (+to-cref) ( xt -- )
   end-reference
>body 5 cells + @
   state @ if postpone literal postpone + postpone +! exit then
   + +! ;

: +to-cref ( -- flag ) >in @ >r '
   dup >body cell+ @ ['] a-ref = if (to-cref) r> drop true
   else drop r> >in ! false then ;

-? : +TO ( n -- )
   LOBJ-COMP +TO-LOCAL ?EXIT \ local object
   LVAR-COMP +TO-LOCAL ?EXIT \ local variable
             +to-cref ?exit \ class ref
             +to-ref ?EXIT \ ref
             +TO-VALUE ?EXIT \ VALUE
   2 'METHOD ! ; IMMEDIATE

: (&of-cref) ( xt -- )
   end-reference
>body 5 cells + @
   state @ if postpone literal then ;

: &of-cref ( -- flag ) >in @ >r '
   dup >body cell+ @ ['] a-ref = if (&of-cref) r> drop true
   else drop r> >in ! false then ;

-? : &of ( n -- )
   LOBJ-COMP &of-LOCAL ?EXIT \ local object
   LVAR-COMP &of-LOCAL ?EXIT \ local variable
             &of-cref ?exit \ class ref
             &of-ref ?EXIT \ ref
             &of-VALUE ?EXIT \ VALUE
   2 'METHOD ! ; IMMEDIATE

end-package

\ -- CREATES --

: creates dup >r builds r> sizeof negate allot ;

: creates[] 8192 over builds[] sizeof 8192 * negate allot ;

\ -- OBJECT --

\ OBJECT - predicate
\ LAST OBJECT
: object
   @ name> >body 3 cells + ;

supreme reopen
   defer: cinit ;
end-class

: builds
   builds last object -> cinit ;

----------------------------------------------------------------------
sftalk_at_forth.com The SwiftForth programming discussion email list
To unsubscribe, send subject "unsubscribe" to sftalk-request_at_forth.com
For list command help, send subject "help" to sftalk-request_at_forth.com
Message archives are located at http://www.forth.com/archive/sftalk
----------------------------------------------------------------------
This list is a forum for SwiftForth users. For product support and
bug reports, please send email to support_at_forth.com
----------------------------------------------------------------------
Received on Sat Apr 10 2010 - 14:29:59 PDT