\ ------------------------------------------------
\ Virtual class file example - not full tested ! -
\ ------------------------------------------------

Class Var

Public
    variable ADDR

    : @ ( -- v ) ADDR COMMON @ ;
    : ! ( v -- ) ADDR COMMON ! ;
    : ? ( -- ) ADDR COMMON ? ;

    : Clear ( -- ) 0 ! ;

    : +! ( v -- ) ADDR COMMON +! ;
    : 1+! ( -- ) @ +! ;

    : NEGATE ( -- ) @ COMMON NEGATE ! ;
End

\ ----------------------

Class VirtFile

Private
    variable _temp
    : _pure-virt ( -- ) TRUE abort" pure virtual" ;

Public
    VIRTUAL: Open ( caddr u fam -- bOK ) _pure-virt ;
    VIRTUAL: Create ( caddr u fam -- bOK ) _pure-virt ;
    VIRTUAL: Close ( -- bOK ) _pure-virt ;
    VIRTUAL: Seek ( ud -- bOK ) _pure-virt ;
    VIRTUAL: Read ( addr count -- u2 bOK ) _pure-virt ;
    VIRTUAL: Write ( addr count -- bOK ) _pure-virt ;
    VIRTUAL: GetSize ( -- len ) _pure-virt ;
    VIRTUAL: Tell ( -- pos ) _pure-virt ;

Public
    : WriteCell ( i -- bOK ) _temp ! _temp 1 cells Write ;
    : WriteChar ( c -- bOK ) _temp c! _temp 1 chars Write ;

    : ReadCell ( -- i bOK ) _temp 1 cells Read nip _temp @ swap ;
    : ReadChar ( -- c bOK ) _temp 1 chars Read nip _temp C@ swap ;
End

\ ----------------------

VirtFile SubClass MemFile

Private
    Var build _mem
    Var build _pos
    Var build _size
    Var build _maxsize
    8 cells constant _BLOCSIZE

Public
    VIRTUAL: Create ( caddr u fam -- bOK )
        rot 2drop
        R/W <> IF FALSE EXIT THEN
        _BLOCSIZE allocate 0= dup
        IF
           swap _mem !
           _BLOCSIZE _maxsize !
           _size Clear _pos Clear
        THEN ;

    VIRTUAL: Open ( caddr u fam -- bOK )
        abort" cannot open a MemFile - use Create" ;

    VIRTUAL: Close ( -- bOK )
        _mem @ free 0= ;

    VIRTUAL: Seek ( ud -- bOK )
        dup 0<
        IF
            _size @ 1- swap -
            dup 0< IF drop FALSE EXIT THEN
        ELSE
            dup _size @ >= IF drop FALSE EXIT THEN
        THEN
        _pos ! TRUE ;

    VIRTUAL: Read ( addr count -- u2 bOK )
        _pos @ over + _size @ >
        IF
            drop _size @ _pos @ -
        THEN
        swap over \ S: count addr count
        _mem @ _pos @ + \ S: count addr count ptr
        -rot move \ S: count
        dup _pos +! TRUE ;

    VIRTUAL: Write ( addr count -- bOK )
        _pos @ over + \ S: addr count endpos
        dup _maxsize @ >= \ S: addr count endpos notok?
        IF
            _BLOCSIZE / 1+ _BLOCSIZE *
            dup _mem @ resize 0= \ S: addr count max ptr ok?
            IF \ S: addr count max ptr
                _mem ! _maxsize ! \ S: addr count
            ELSE
                2drop 2drop
                FALSE EXIT
            THEN \ S: addr count
        ELSE
            drop
        THEN \ S: addr count
        _mem @ _pos @ + \ S: addr count ptrstart
        swap \ S: addr ptrstart count
        dup _pos +! move \ S: -
        _pos @ _size @ >
        IF _pos @ _size ! THEN
        TRUE ;

    VIRTUAL: GetSize ( -- len ) _size @ ;

    VIRTUAL: Tell ( -- pos ) _pos @ ;
End

\ ----------------------

VirtFile SubClass DiskFile

Public
    Var build fileid

    VIRTUAL: Open ( caddr u fam -- bOK )
        OPEN-FILE 0= dup
        IF swap fileid ! ELSE nip THEN ;

    VIRTUAL: Create ( caddr u fam -- bOK )
        CREATE-FILE 0= dup
        IF swap fileid ! ELSE nip THEN ;

    VIRTUAL: Close ( -- bOK )
        fileid @ CLOSE-FILE 0= ;

    VIRTUAL: Seek ( ud -- bOK )
        fileid @ REPOSITION-FILE 0= ;

    VIRTUAL: Read ( addr count -- u2 bOK )
        fileid @ READ-FILE 0= ;

    VIRTUAL: Write ( addr count -- bOK )
        fileid @ WRITE-FILE 0= ;

    VIRTUAL: GetSize ( -- len )
        fileid @ FILE-SIZE IF drop 0 THEN ;

    VIRTUAL: Tell ( -- pos )
        fileid @ FILE-POSITION IF drop 0 THEN ;
End

{
cr
..( File test - 1 2 3 if OK )
cr
\ MemFile build m
DiskFile build m
S" \TEST.TTT" R/W m Create drop

0 m seek
1 m WriteCell drop
2 m WriteCell drop
3 m WriteCell drop

0 m Seek
m ReadCell drop .
m ReadCell drop .
m ReadCell drop .
m Close
}

.
Received on Mon Jan 25 1999 - 19:21:55 PST