\ *****************************************************************************
\ * Copyright (c) 2004, 2008 IBM Corporation
\ * All rights reserved.
\ * This program and the accompanying materials
\ * are made available under the terms of the BSD License
\ * which accompanies this distribution, and is available at
\ * http://www.opensource.org/licenses/bsd-license.php
\ *
\ * Contributors:
\ *     IBM Corporation - initial implementation
\ ****************************************************************************/


\ =============================================================================
\ =============================================================================


\ The deblocker.  Allows block devices to be used as a (seekable) byte device.

s" deblocker" device-name

INSTANCE VARIABLE offset
INSTANCE VARIABLE block-size
INSTANCE VARIABLE max-transfer
INSTANCE VARIABLE my-block
INSTANCE VARIABLE adr
INSTANCE VARIABLE len
INSTANCE VARIABLE fail-count

: open
  s" block-size" ['] $call-parent CATCH IF 2drop false EXIT THEN
  block-size !
  s" max-transfer" ['] $call-parent CATCH IF 2drop false EXIT THEN
  max-transfer !
  block-size @ alloc-mem my-block !
  0 offset !
  true ;
: close  my-block @ block-size @ free-mem ;

: seek ( lo hi -- status ) \ XXX: perhaps we should fail if the underlying
                           \      device would fail at this offset
  lxjoin offset !  0 ;
: block+remainder ( -- block# remainder )  offset @ block-size @ u/mod swap ;
: read-blocks ( addr block# #blocks -- actual )  s" read-blocks" $call-parent ;
: read ( addr len -- actual )
  dup >r  len ! adr !
  \ First, handle a partial block at the start.
  block+remainder dup IF ( block# offset-in-block )
  >r my-block @ swap 1 read-blocks drop
  my-block @ r@ + adr @ block-size @ r> - len @ min dup >r move
  r> dup negate len +! dup adr +! offset +! ELSE 2drop THEN

  \ Now, in a loop read max. max-transfer sized runs of whole blocks.
  0 fail-count !
  BEGIN len @ block-size @ >= WHILE
    adr @ block+remainder drop len @ max-transfer @ min block-size @ / read-blocks
    dup 0= IF
      1 fail-count +!
      fail-count @ 5 >= IF r> drop EXIT THEN
    ELSE
      0 fail-count !
    THEN
    block-size @ * dup negate len +! dup adr +! offset +!
  REPEAT

  \ And lastly, handle a partial block at the end.
  len @ IF my-block @ block+remainder drop 1 read-blocks drop
  my-block @ adr @ len @ move THEN

  r> ;

: write-blocks ( addr block# #blocks -- #writtenblks )
    s" write-blocks" $call-parent
;

: write ( addr len -- actual )
    dup block-size @ mod IF
        ." ERROR: Can not write partial sector length." cr
        2drop 0 EXIT
    THEN
    block-size @ /                             ( addr #blocks )
    offset @                                   ( addr #blocks offset )
    dup block-size @ mod IF
        ." ERROR: Can not write at partial sector offset." cr
        3drop 0 EXIT
    THEN
    block-size @ / swap                        ( addr block# #blocks )
    write-blocks                               ( #writtenblks )
    block-size @ *
    dup offset +!
;