Groups | Search | Server Info | Keyboard shortcuts | Login | Register [http] [https] [nntp] [nntps]

Groups > comp.lang.forth > #11988 > unrolled thread

OOP packages

Back to article view | Back to comp.lang.forth

Contents

  OOP packages hwfwguy@gmail.com - 2012-05-08 09:31 -0700
    Re: OOP packages "Elizabeth D. Rather" <erather@forth.com> - 2012-05-08 09:10 -1000
      Re: OOP packages stephenXXX@mpeforth.com (Stephen Pelc) - 2012-05-08 20:17 +0000
        Re: OOP packages hwfwguy@gmail.com - 2012-05-08 18:26 -0700
        Re: OOP packages anton@mips.complang.tuwien.ac.at (Anton Ertl) - 2012-05-09 11:34 +0000
          Re: OOP packages Doug Hoffman <glidedog@gmail.com> - 2012-05-09 08:00 -0400
            Re: OOP packages Bernd Paysan <bernd.paysan@gmx.de> - 2012-05-09 19:49 +0200
            Re: OOP packages anton@mips.complang.tuwien.ac.at (Anton Ertl) - 2012-05-10 11:39 +0000
              Re: OOP packages Doug Hoffman <glidedog@gmail.com> - 2012-05-10 12:48 -0400
            Re: OOP packages Hugh Aguilar <hughaguilar96@yahoo.com> - 2012-05-10 02:26 -0700
    Re: OOP packages BruceMcF <agila61@netscape.net> - 2012-05-08 12:39 -0700
    Re: OOP packages Doug Hoffman <glidedog@gmail.com> - 2012-05-08 15:56 -0400
    Re: OOP packages hwfwguy@gmail.com - 2012-05-10 17:04 -0700
      Re: OOP packages Hugh Aguilar <hughaguilar96@yahoo.com> - 2012-05-11 02:02 -0700
      Re: OOP packages Albert van der Horst <albert@spenarnc.xs4all.nl> - 2012-05-15 10:32 +0000
      Re: OOP packages Doug Hoffman <glidedog@gmail.com> - 2012-05-15 08:35 -0400
        Re: OOP packages mhx@iae.nl (Marcel Hendrix) - 2012-05-15 20:37 +0200
          Re: OOP packages Doug Hoffman <glidedog@gmail.com> - 2012-05-15 15:22 -0400
          Re: OOP packages Doug Hoffman <glidedog@gmail.com> - 2012-05-15 21:50 -0400
            Re: OOP packages mhx@iae.nl (Marcel Hendrix) - 2012-05-17 08:11 +0200
              Re: OOP packages Doug Hoffman <glidedog@gmail.com> - 2012-05-17 08:55 -0400
                Re: OOP packages Gerry Jackson <gerry@jackson9000.fsnet.co.uk> - 2012-05-22 08:39 +0100
                  Re: OOP packages Doug Hoffman <glidedog@gmail.com> - 2012-05-22 07:02 -0400
                    Re: OOP packages Gerry Jackson <gerry@jackson9000.fsnet.co.uk> - 2012-05-22 13:14 +0100
                    Re: OOP packages Coos Haak <chforth@hccnet.nl> - 2012-05-22 18:11 +0200
                      Re: OOP packages Doug Hoffman <glidedog@gmail.com> - 2012-05-22 14:23 -0400
                        Re: OOP packages Coos Haak <chforth@hccnet.nl> - 2012-05-23 19:47 +0200
                          Re: OOP packages Doug Hoffman <glidedog@gmail.com> - 2012-05-23 14:58 -0400
                    Re: OOP packages Doug Hoffman <glidedog@gmail.com> - 2012-05-31 07:43 -0400
              Re: OOP packages "Peter Knaggs" <pjk@bcs.org.uk> - 2012-05-17 19:31 +0100
                Re: OOP packages Hugh Aguilar <hughaguilar96@yahoo.com> - 2012-05-17 21:59 -0700
                  Re: OOP packages digital.wilderness@googlemail.com - 2012-05-18 01:51 -0700

Page 2 of 2 — ← Prev page 1 [2]

#12224

On 5/17/12 2:11 AM, Marcel Hendrix wrote:


> Actually, only one change is necessary: iForth's compiled IS is
> written as [IS], like this:

I don't see [IS] in the standard or a restriction on using IS in 
compilation.  Maybe I'm using the wrong reference: forth11-1.pdf.

> Conclusion: This OOP package works on all major Forths with only
> a single cosmetic (is DEFER standard already?) change.

I do see DEFER in the standard, at least in the same reference as above.

-Doug

p.s. micro-FMS is now down to about ~30 lines of code

[toc] | [prev] | [next] | [standalone]

#12367

On 17/05/2012 13:55, Doug Hoffman wrote:
> On 5/17/12 2:11 AM, Marcel Hendrix wrote:
>
>
>> Actually, only one change is necessary: iForth's compiled IS is
>> written as [IS], like this:
>
> I don't see [IS] in the standard or a restriction on using IS in
> compilation. Maybe I'm using the wrong reference: forth11-1.pdf.
>
>> Conclusion: This OOP package works on all major Forths with only
>> a single cosmetic (is DEFER standard already?) change.
>
> I do see DEFER in the standard, at least in the same reference as above.
>
> -Doug
>
> p.s. micro-FMS is now down to about ~30 lines of code

Are you going to post the code for this slimmed down micro-FMS? I'm 
interested in seeing it.

-- 
Gerry

[toc] | [prev] | [next] | [standalone]

#12376

On 5/22/12 3:39 AM, Gerry Jackson wrote:

> Are you going to post the code for this slimmed down micro-FMS? I'm
> interested in seeing it.

Could be trimmed even further but it then becomes painful to use, IMO.

-Doug

\ micro-FMS2 Douglas B. Hoffman 05/18/12
\ Full encapsulation of data and methods.
\ Polymorphism with no restrictions on inheritance order.
\ Dynamic (late) binding of methods.
\ Duck typing.
\ Class variables.
\ Instantiate objects in the dictionary or the heap.
\ No juggling of object in method definitions.

\ 1428 bytes on Carbon MacForth
\ 32  lines of code

0 value self
0 value ^class
: dfa ( class -- a)  cell+ ;
: sfa ( class -- a) 2 cells + ;
: wida ( class -- a) 3 cells + ;
4 cells constant classSize
: fm  ( sel class -- xt) begin @ dup while 2dup cell+ @ =
   if [ 2 cells ] literal + nip @ exit then repeat throw ;
create object  0 , 0 ,
: <super ( -- wn..w1 n) here to ^class classSize allot ' >body
   dup ^class classSize move ^class sfa !  get-order wordlist dup
   set-current ^class wida ! ^class >r get-order begin r@ wida @
   swap 1+ r> sfa @ >r  r@ object = until r> drop set-order ;
: selector  ( name --) create does> over 1 cells - @  fm
   self >r swap to self execute r>  to self ;
: getselect  ( -- sel) >in @  bl word find
   if >body nip else drop >in ! selector here then ;
: :m  ( name -- a xt) forth-wordlist set-current
   getselect ^class here over @ , swap ! , here 0 , :noname ;
: ;m ( a xt --) postpone ; swap ! ; immediate
: super ( name --) ' >body ^class sfa @ fm compile, ; immediate
: (ivar) ( name -- a) create immediate ,
   does> @ postpone literal postpone self postpone + ;
: bytes ( n name --) ^class dfa @ (ivar) ^class dfa +! ;
: dict-allot ( n+cell -- o) align here swap ( n ) allot ;
: heap-allocate ( n+cell -- o) allocate throw ;
defer allotocate ( n+cell -- o)
: (mo) ( cls - o) dup dfa @ cell+ allotocate tuck ! cell+ ;
: mo ( name xt - o) is allotocate ' >body state @
   if postpone literal postpone (mo) else (mo) then ;
: dict> ['] dict-allot mo ; immediate
: heap> ['] heap-allocate mo ; immediate
: <free  ( o --) 1 cells - free throw ;

\ example classes

1 cells constant cell

create var <super object \ var is subclass of object
   cell bytes data
  :m !: ( n -- ) data ! ;m
  :m +: ( n -- ) data +! ;m
  :m @: ( -- n ) data @ ;m
  :m p: ( -- ) self @: . ;m \ print self
  :m init: 0 data ! ;m
set-order

dict> var value x
33 x !:
cr .( print var x )
x p:

heap> var value hx
hx init:
cr .( print var hx )
hx p:
hx <free

create ptr <super var
  cell bytes size \ size, in bytes, of memory allocated
  variable ptr-cnt 0 ptr-cnt ! \ class variable
  :m size: ( -- n )  size @ ;m
  :m free:
     self @ ?dup if free throw 0 self ! then
         0 size !  -1 ptr-cnt +! ;m
  :m new:  ( size -- )
     dup allocate throw  self !   size !
     1 ptr-cnt +! ;m
  :m resize:  ( newsize -- )
     self @ over resize throw  self !  size !  ;m
  :m cnt: ( -- n) ptr-cnt @ ;m
set-order

create string <super ptr
  :m new: ( addr len -- )
    dup super new: ( addr len ) self @ swap ( addr self len ) move ;m
  :m add: ( addr len -- ) \ add text to end of string
    dup ( addr-src len len )
    size @ dup >r + self resize:  \ addr-src len
    self @ r> + ( addr-src len dest) swap move ;m
  :m @: ( -- addr len ) self @  size @ ;m
  :m p: self @: type ;m
  :m +: ( char -- ) \ add char to end of string
      size @ 1+ self resize:   self @: + 1- c! ;m
set-order

dict> string value s
s" hello" s new:
cr .( print s )
s p:
cr .( print s )
s"  world" s add:  s p:
cr .( print s )
char ! s +: s p:
cr .( inspect class variable )
s cnt: .

heap> string value hs
s" goodbye" hs new:
cr .( print hs )
hs p:
cr .( inspect class variable )
hs cnt: .

s free:
hs free: hs <free
cr .( inspect class variable )
s cnt: .

[toc] | [prev] | [next] | [standalone]

#12380

On 22/05/2012 12:02, Doug Hoffman wrote:
> On 5/22/12 3:39 AM, Gerry Jackson wrote:
>
>> Are you going to post the code for this slimmed down micro-FMS? I'm
>> interested in seeing it.
>
> Could be trimmed even further but it then becomes painful to use, IMO.
>

[...]

Thanks, I'll have a detailed look at it.

-- 
Gerry

[toc] | [prev] | [next] | [standalone]

#12384

Op Tue, 22 May 2012 07:02:03 -0400 schreef Doug Hoffman:

<snip>
> \ 1428 bytes on Carbon MacForth
> \ 32  lines of code
> 
> 0 value self
> 0 value ^class
>: dfa ( class -- a)  cell+ ;
>: sfa ( class -- a) 2 cells + ;
>: wida ( class -- a) 3 cells + ;
> 4 cells constant classSize
>: fm  ( sel class -- xt) begin @ dup while 2dup cell+ @ =
>    if [ 2 cells ] literal + nip @ exit then repeat throw ;

Why this not working (0) THROW ? Do you mean   DROP THROW ?


-- 
Coos

CHForth, 16 bit DOS applications
http://home.hccnet.nl/j.j.haak/forth.html 

[toc] | [prev] | [next] | [standalone]

#12389

On 5/22/12 12:11 PM, Coos Haak wrote:
> Op Tue, 22 May 2012 07:02:03 -0400 schreef Doug Hoffman:
>
> <snip>
>> \ 1428 bytes on Carbon MacForth
>> \ 32  lines of code
>>
>> 0 value self
>> 0 value ^class
>> : dfa ( class -- a)  cell+ ;
>> : sfa ( class -- a) 2 cells + ;
>> : wida ( class -- a) 3 cells + ;
>> 4 cells constant classSize
>> : fm  ( sel class -- xt) begin @ dup while 2dup cell+ @ =
>>     if [ 2 cells ] literal + nip @ exit then repeat throw ;
>
> Why this not working (0) THROW ? Do you mean   DROP THROW ?

You should only get to the throw on an error condition (message not found).

Does the code run without error as received?

If not, does your Forth have any already-defined words that conflict 
with any of the message names ( !: +: @: p: init: etc.)?  If so, then 
you must force the redefinition by using, e.g., "selector !:" prior to 
the class definition.

-Doug

[toc] | [prev] | [next] | [standalone]

#12406

Op Tue, 22 May 2012 14:23:16 -0400 schreef Doug Hoffman:

> On 5/22/12 12:11 PM, Coos Haak wrote:
>> Op Tue, 22 May 2012 07:02:03 -0400 schreef Doug Hoffman:
>>
>> <snip>
>>> \ 1428 bytes on Carbon MacForth
>>> \ 32  lines of code
>>>
>>> 0 value self
>>> 0 value ^class
>>> : dfa ( class -- a)  cell+ ;
>>> : sfa ( class -- a) 2 cells + ;
>>> : wida ( class -- a) 3 cells + ;
>>> 4 cells constant classSize
>>> : fm  ( sel class -- xt) begin @ dup while 2dup cell+ @ =
>>>     if [ 2 cells ] literal + nip @ exit then repeat throw ;
>>
>> Why this not working (0) THROW ? Do you mean   DROP THROW ?
> 
> You should only get to the throw on an error condition (message not found).
> 
> Does the code run without error as received?

Your definition is like this
: fm ( sel class -- xt ) begin @ dup while <left out success> repeat  throw ;
When '@ DUP' detects a zero, WHILE jumps to after REPEAT and THROW finds a
zero, so nothing happens and sel is left on the stack

: fm begin @ dup while <..> repeat drop throw ; would work
: fm begin @ ?dup while <..> repeat throw ; would work too.

-- 
Coos

CHForth, 16 bit DOS applications
http://home.hccnet.nl/j.j.haak/forth.html 

[toc] | [prev] | [next] | [standalone]

#12408

On 5/23/12 1:47 PM, Coos Haak wrote:

> Your definition is like this
> : fm ( sel class -- xt ) begin @ dup while<left out success>  repeat  throw ;
> When '@ DUP' detects a zero, WHILE jumps to after REPEAT and THROW finds a
> zero, so nothing happens and sel is left on the stack
>
> : fm begin @ dup while<..>  repeat drop throw ; would work
> : fm begin @ ?dup while<..>  repeat throw ; would work too.

You're right.  Either of the above would be better.

Thank you.

-Doug

[toc] | [prev] | [next] | [standalone]

#12633

Re: microFMS

It's now down to about 1200 bytes on Carbon MacForth and under 30 lines 
of code.  Provides fast dynamic binding and more examples.

http://soton.mpeforth.com/flag/fms/microFMS.f

-Doug

[toc] | [prev] | [next] | [standalone]

#12237

Marcel Hendrix wrote:
>
> Conclusion: This OOP package works on all major Forths with only
> a single cosmetic (is DEFER standard already?) change.

DEFER (and IS) was one of the first proposals to be accepted into
the 200x standard way back in 2005.

-- 
Peter Knaggs

[toc] | [prev] | [next] | [standalone]

#12256

On May 17, 11:31 am, "Peter Knaggs" <p...@bcs.org.uk> wrote:
> Marcel Hendrix wrote:
>
> > Conclusion: This OOP package works on all major Forths with only
> > a single cosmetic (is DEFER standard already?) change.
>
> DEFER (and IS) was one of the first proposals to be accepted into
> the 200x standard way back in 2005.
>
> --
> Peter Knaggs

In my novice package I provide DEFER and IS because they are
traditional.

I also provide VECTOR which is much more efficient.

[toc] | [prev] | [next] | [standalone]

#12263

Is there a more recent comparison of object oriented packages than Brad Rodriguez's survey?

http://www.bradrodriguez.com/papers/oofs.htm

Thanks,

John

[toc] | [prev] | [standalone]

Page 2 of 2 — ← Prev page 1 [2]

Back to top | Article view | comp.lang.forth

csiph-web