91 lines
3 KiB
Forth
91 lines
3 KiB
Forth
\ *****************************************************************************
|
|
\ * 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 +!
|
|
;
|