\ Copyright 1998 Jean-Francois Brouillet
\ included in this package with permission
\ He cautions: "As I said, I don't think it qualifies for "production
\ qualtity" status (among other things, I'd define powers of two only
\ sizes so that my indices would "roll-over" with very little
\ overhead.)"

\ Article: 37100 of comp.lang.forth
\ Path: news.tuwien.ac.at!aconews.univie.ac.at!newscore.univie.ac.at!news-spur1.maxwell.syr.edu!news.maxwell.syr.edu!newsfeed.atl.bellsouth.net!uunet!uunet!in4.uu.net!news7-gui.server.ntli.net!news-feed.ntli.net!not-for-mail
\ From: "Jean-Francois Brouillet" <jean-francois.brouillet@virgin.net>
\ Newsgroups: comp.lang.forth
\ Subject: Anton Ertl's objects.fs's experiment
\ Date: Thu, 17 Sep 1998 23:41:27 +0100
\ Organization: Virgin News Service
\ Lines: 129
\ Message-ID: <6ts34s$o8d$1@nclient3-gui.server.virgin.net>
\ NNTP-Posting-Host: 194.168.123.41
\ Mime-Version: 1.0
\ Content-Type: text/plain; charset="US-ASCII"
\ Content-Transfer-Encoding: 7bit
\ X-Newsreader: Microsoft Outlook Express for Macintosh - 4.01 (295)
\ Xref: news.tuwien.ac.at comp.lang.forth:37100

\ Of all the available Forth OO models I've found on the net
\ so far, I'm beginning to favor Anton Ertl's objects.fs.

\ Here's a plain vanillia (non optimized, but the purpose was
\ more to experiment with Anton's syntax/semantics than to get
\ production quality code) Fifo class.

\ The only two comments I have up to now on this OO model is that

\ 1)  it doesn't seem possible to invoke a method before it is defined
\     -- see my other `FORWARD' thread --, practice wich is very common
\     in all (non Forth) OO languages I'm used to.
    
\ 2)  It seems to me that ;M is *always* followed by either METHOD
\     or OVERRIDE. If this is indeed the case, it could be worthwhile
\     to define (say) ;METHOD and ;OVERRIDE that would do both at once ?
    
    
\ For the following class to compile, you need, in addition to Anton's
\ struct.fs and object.fs the following definitions:

: AND! ( x addr ) DUP @ ROT AND SWAP ! ;
: OR! ( x addr ) DUP @ ROT OR SWAP ! ;
: XOR! ( x addr ) DUP @ ROT XOR SWAP ! ;
: INVERT! ( addr ) DUP @ INVERT SWAP ! ;


OBJECT CLASS

 1 CONSTANT  OVERRUN
 2 CONSTANT  UNDERRUN

 cell% INST-VAR mPutIndex
 cell% INST-VAR mGetIndex
 cell% INST-VAR mSizeMax
 cell% INST-VAR mCurrentSize
 cell% INST-VAR mBuffer
 cell% INST-VAR mFlags             \ only bits 0-1 are currently used

 M: ( -- )  0 mPutIndex !
            0 mGetIndex !
            0 mCurrentSize !
            0 mFlags !                            ;M METHOD clear

 M: ( buffer size -- )
           THIS clear mSizeMax ! mBuffer !        ;M OVERRIDES construct

 \ Adjusts mGetIndex so that the whole fifo becomes available for get.
 \ Used when an overrun occurs to discard all but the last received
 \ bytes (instead of the easier but naive strategy of keeping the oldest)
 M: ( -- )  mPutIndex @ 1 - mGetIndex !
                mGetIndex @ 0< IF
                mSizeMax @ mGetIndex +!
            THEN                                  ;M METHOD _pinGet
 
 M: ( b -- f )  mFlags @ AND 0= 0=                ;M METHOD _flag?
 M: ( b -- )    mFlags OR!                        ;M METHOD _flag!
 M: ( b -- )    INVERT mFlags AND!                ;M METHOD _flag0!

 M: ( -- )      OVERRUN THIS _flag!   
                THIS _pinGet                      ;M METHOD _overrun!
 M: ( -- )      OVERRUN THIS _flag0!              ;M METHOD _overrun0!
 M: ( -- )      UNDERRUN THIS _flag!              ;M METHOD _underrun!
 M: ( -- )      UNDERRUN THIS _flag0!             ;M METHOD _underrun0!

 M: ( -- f )    OVERRUN THIS _flag?               ;M METHOD overrun?
 M: ( -- f )    UNDERRUN THIS _flag?              ;M METHOD underrun?

 M: ( -- f )    mCurrentSize @ mSizeMax @ >=      ;M METHOD full?
 M: ( -- f )    mCurrentSize @ 0<=                ;M METHOD empty?

 M: ( c -- )    mBuffer @ mPutIndex @ + C!
                1 CHARS mCurrentSize +!
                1 CHARS mPutIndex +!
                mPutIndex @ mSizeMax @ >= IF
                    0 mPutIndex !
                THEN                              ;M METHOD _put

 M: ( c -- )    THIS full? IF
                    DROP
                    THIS _overrun!
                ELSE
                    THIS _overrun0!
                    THIS _put
                THEN                              ;M METHOD put

 M: ( -- c )    THIS empty? IF
                    THIS _underrun!
                    -1
                ELSE
                    THIS _underrun0!
                    mBuffer @ mGetIndex @ + C@
                    -1 CHARS mCurrentSize +!
                    1 CHARS  mGetIndex +!
                    mGetIndex @ mSizeMax @ >= IF
                        0 mGetIndex !
                    THEN
               THEN                               ;M METHOD get
END-CLASS Fifo

DECIMAL
CREATE buffer 256 CHARS ALLOT

buffer 16 Fifo heap-new CONSTANT myFifo

: test-fifo
    myFifo clear
    12 0 DO I myFifo put LOOP

    BEGIN myFifo empty? 0= WHILE
        myFifo get .
    REPEAT
;

: test2-fifo ( n -- )
     myFifo clear
 
     0 DO I myFifo put LOOP

     BEGIN myFifo empty? 0= WHILE
         myFifo get .
     REPEAT
;


\ --
\ jean-francois.brouillet@virgin.net
\ verec@sms.ndirect.co.uk
\ verec@micronet.fr