( StorMem )

needs module: modules
needs dump dump

api: MemHandleNew
api: MemHandleFree

module: StorMem
module: _
0
cell -- addr
cell -- handle
cell -- alloted
cell -- used
cell -- preallot
cell -- here
constant /struct
: size-align ( s1 sm -- s2 )
	preallot @ + ;
: resize ( size sm -- )
	dup>r handle @
	dup MemHandleUnlock throw
	swap 2dup
	MemHandleResize throw
	r@ alloted !
	MemHandleLock
	r> addr ! ;
: ?resize ( sm -- )
	>r
	r@ used @ r@ alloted @ > if
		r@ used @ r@ size-align
		r@ resize then rdrop ;
create buf cell allot
;module
: _ also _ NextWord evaluate previous
	; immediate
_ /struct constant /struct
: Addr>rel ( sm-addr sm -- addr )
	_ addr @ + >rel ;
: Show ( sm -- )
	>r
	r@ _ addr @ cr ." addr=" .
	r@ _ handle @ cr ." handle=" .
	r@ _ used @ cr ." used=" .
	r@ _ alloted @ cr ." alloted=" .
	r@ _ preallot @ cr ." preallot=" .
	r@ _ here @ cr ." here=" .
	0 r@ addr>rel r> _ used @
	cr dump ;
: Init ( dbOR size preall -- sm )
	/struct allocate throw >r
	r@ _ preallot !
	dup r@ _ alloted !
	over if
		DmNewHandle ?DmErr
	else
		MemHandleNew
		?dup 0=
			abort" can't allocate"
		drop
	then
	dup r@ _ handle !
	MemHandleLock r@ _ addr !
	0 r@ _ used !
	0 r@ _ here ! r> ;
: InitDB ( dbOR size preall -- sm )
	/struct allocate throw >r
	r@ _ preallot !
	dup r@ _ alloted !
	DmNewHandle ?DmErr
	dup r@ _ handle !
	MemHandleLock r@ _ addr !
	0 r@ _ used !
	0 r@ _ here ! r> ;
: Open ( handle here preallot -- sm )
	/struct allocate throw >r
	r@ _ preallot !
	r@ _ here !
	dup r@ _ handle !
	dup MemHandleSize
	dup r@ _ alloted ! r@ _ used !
	MemHandleLock r@ _ addr ! r> ;
: Close ( sm -- )
	dup>r _ handle @
	dup MemHandleUnlock throw
	r@ _ used @
	MemHandleResize throw
	r> free throw ;
: Done ( sm -- )
	dup _ handle @
	dup MemHandleUnlock throw
	MemHandleFree throw
	free throw ;
: OpenChunk ( handle -- smc )
	/struct allocate throw >r
	dup MemHandleSize
	over MemHandleLock >rel
	2dup
	+ /struct - r@ /struct move
	>abs r@ _ addr !
	r@ _ alloted !
	r@ _ handle ! r> ;
: CloseChunk ( smc -- )
	>r
	r@ _ used @ /struct + r@
		_ resize
	r@ _ addr @
	r@ _ alloted @ /struct -
	r@ >abs /struct DmWrite throw
	r@ _ handle @
	MemHandleUnlock throw
	r> free throw ;
: Handle ( sm -- handle ) _ handle @ ;
: Used ( sm -- size ) _ used @ ;
: SetUsed ( size sm -- )
	dup>r _ used !
	 r> _ ?resize ;
: Move ( addr sm-addr u sm -- )
	>r
	2dup +
	dup r@ _ used @ > if
		r@ SetUsed else drop then
	r> _ addr @ swap >r
	swap rot >abs r>
	DmWrite throw ;
: Here ( sm -- here ) _ here @ ;
: Allot ( size sm -- )
	>r
	r@ _ here +!
	r@ _ here @ r@ _ used @ > if
		r@ _ here @ SetUsed then
	rdrop ;
: ! ( n sm-addr sm -- )
	rot _ buf ! _ buf -rot cell swap
	move ;
: w! ( n sm-addr sm -- )
	rot _ buf w! _ buf -rot 2 swap
	move ;
: c! ( c sm-addr sm -- )
	rot _ buf c! _ buf -rot 1 swap
	move ;
: @ ( sm-addr sm -- n )
	addr>rel @ ;
: w@ ( sm-addr sm -- n )
	addr>rel w@ ;
: c@ ( sm-addr sm -- c )
	addr>rel c@ ;
: , ( n sm -- )
  dup>r Here r@ ! 4 r> _ here +! ;
: w, ( n sm -- )
  dup>r Here r@ w! 2 r> _ here +! ;
: c, ( n sm -- )
  dup>r Here r@ c! 1 r> _ here +! ;
: s, ( addr u sm -- )
	>r tuck r@ Here swap r@ Move
	r> _ here +! ;
: Align ( sm -- )
	dup Here 1 and if
		0 swap c, else
		drop then ;
: csz, ( addr u sm -- )
	>r
	dup r@ c,
	r@ s,
	0 r@ c,
	r> Align ;
;module
\eof
{{ StorMem
1 1 Init constant sm
123 sm ,
sm show