\ Klaus Schleisiek's dynamic memory allocation (FORML'88) seedForth-version uh 2018-06-20
-program dynamic.seed
+PROGRAM dynamic.seed
\ extend seedForth core with words required by dynamic memory
\ -------------------------------------
-': _variable ( -- ) create 0 #, , does> ;' \ a seedForth defining word
-: Variable ( <name> -- ) fun: _variable ; \ macro
+Definer Variable ( <name> x -- ) create 0 , does> ;
+Definer Constant ( x <name> -- ) create , does> @ ;
-': doconst ( -- ) does> @ ;' \ a does> w/o create path sets behaviour
-: Constant ( <name> x -- ) fun: create , doconst ; \ macro
+: over ( x1 x2 -- x1 x2 x1 ) >r dup r> swap ;
-': over ( x1 x2 -- x1 x2 x1 ) >r dup r> swap ;'
+: 2dup ( x1 x2 -- x1 x2 x1 x2 ) over over ;
+: 2drop ( x1 x2 -- ) drop drop ;
-': 2dup ( x1 x2 -- x1 x2 x1 x2 ) over over ;'
-': 2drop ( x1 x2 -- ) drop drop ;'
+: < ( u1 u2 -- f ) - 0< ;
+: > ( u1 u2 -- f ) swap < ;
+: u< < ;
+: = ( x1 x2 -- f ) - 0= ;
+: max ( x1 x2 -- x3 ) 2dup < IF swap THEN drop ;
+: rot ( x1 x2 x3 -- x2 x3 x1 ) >r swap r> swap ;
-': < ( u1 u2 -- f ) - 0< ;'
-': > ( u1 u2 -- f ) swap < ;'
-': u< < ;'
-': = ( x1 x2 -- f ) - 0= ;'
-': max ( x1 x2 -- x3 ) 2dup < IF swap THEN drop ;'
-': rot ( x1 x2 x3 -- x2 x3 x1 ) >r swap r> swap ;'
+: move ( c-addr1 c-addr2 u -- )
+ BEGIN dup WHILE >r over c@ over c! 1 + swap 1 + swap r> 1 - REPEAT drop 2drop ;
-': move ( c-addr1 c-addr2 u -- )
- BEGIN dup WHILE >r over c@ over c! 1 #, + swap 1 #, + swap r> 1 #, - REPEAT drop 2drop ;'
+: r@ ( -- x ) r> r> dup >r swap >r ;
-: r@ ( -- x ) r> dup >r ;
+: cell+ ( addr1 -- addr2 ) 1 cells + ;
-': cell+ ( addr1 -- addr2 ) 1 #, cells + ;'
-
-': 2* ( x1 -- x2 ) dup + ;'
-': 256* ( x1 -- x2 ) 2* 2* 2* 2* 2* 2* 2* 2* ;'
+: 2* ( x1 -- x2 ) dup + ;
+: 256* ( x1 -- x2 ) 2* 2* 2* 2* 2* 2* 2* 2* ;
+\ Utility words for debugging
+\ ----------------------------
+\ hex number output
+
+: 1- 1 - ;
+: 1+ 1 + ;
+: nip swap drop ;
+
+: .hexdigit ( n -- ) dup 9 > IF lit [ 'A' 10 - , ] ELSE '0' THEN + emit ;
+
+\ : 2* ( x1 -- x2 ) dup + ;
+
+: space 32 emit ;
+
+: cr 10 emit 13 emit ;
+
+
+\ if we don't have u2/ but only 2* and 0< we need to implement u2/ with a loop. Candidate for primitive
+: u2/ ( x1 -- x2 )
+ 0 8 cells 1- BEGIN ?dup WHILE >r 2* over 0< IF 1+ THEN >r 2* r> r> 1- REPEAT nip ;
+
+: odd? ( x1 -- f ) dup u2/ 2* = 0= ;
+
+: 2/mod ( x1 -- x2 r ) \ swapped results
+ dup u2/ swap odd? negate ;
+
+: 16/mod ( x -- x r ) \ swapped results
+ 2/mod >r 2/mod >r 2/mod >r 2/mod 2* r> + 2* r> + 2* r> + ;
+
+: #### ( x -- )
+ 16/mod >r 16/mod >r 16/mod >r 16/mod >r 16/mod >r 16/mod >r 16/mod >r
+ .hexdigit r> .hexdigit r> .hexdigit r> .hexdigit r> .hexdigit
+ r> .hexdigit r> .hexdigit r> .hexdigit space ;
+
+: (.) ( x -- )
+ ?dup IF 16/mod >r (.) r> .hexdigit THEN ;
+
+: u. ( x -- )
+ ?dup IF (.) ELSE '0' emit THEN space ;
+
+: . ( n -- ) dup 0< IF '-' emit negate THEN u. ;
+
+: /string ( x1 x2 x3 -- x4 x5 ) swap over - >r + r> ;
+
+: type ( c-addr u -- )
+ BEGIN dup WHILE over c@ emit 1 /string REPEAT 2drop ;
+
+Macro ." ( ccc" -- )
+ seed s"
+ seed type
+end-macro
+
\ dynamic memory
\ -------------------------------------
Variable anchor
-50 # Constant waste
+50 Constant waste
-128 # 256* 256* 256* ( 32bit ) Constant #free \ sign bit
-#free 1 # - ( 31bit ) Constant #max
+128 256* 256* 256* ( 32bit ) Constant #free \ sign bit
+#free 1 - ( 31bit ) Constant #max
-': size ( mem -- size ) 1 #, cells - @ #max and ;'
+: size ( mem -- size ) 1 cells - @ #max and ;
-': addr&size ( mem -- mem size ) dup size ;'
+: addr&size ( mem -- mem size ) dup size ;
-': above ( mem -- >mem ) addr&size + 2 #, cells + ;'
+: above ( mem -- >mem ) addr&size + 2 cells + ;
-': use ( mem size -- )
- dup >r swap 2dup 1 #, cells - ! r> #max and + ! ;'
+: use ( mem size -- )
+ dup >r swap 2dup 1 cells - ! r> #max and + ! ;
-': release ( mem size -- ) #free or use ;'
+: release ( mem size -- ) #free or use ;
-': fits? ( size -- mem | false ) >r anchor @
+: fits? ( size -- mem | false ) >r anchor @
BEGIN addr&size r@ u< 0=
IF r> drop unnest THEN
@ dup anchor @ =
- UNTIL 0= r> drop ;'
+ UNTIL 0= r> drop ;
-': link ( mem >mem <mem -- )
- >r 2dup cell+ ! over ! r> 2dup ! swap cell+ ! ;'
+: link ( mem >mem <mem -- )
+ >r 2dup cell+ ! over ! r> 2dup ! swap cell+ ! ;
-': @links ( mem -- <mem mem> ) dup @ swap cell+ @ ;'
+: @links ( mem -- <mem mem> ) dup @ swap cell+ @ ;
-': setanchor ( mem -- mem )
- dup anchor @ = IF dup @ anchor ! THEN ;'
+: setanchor ( mem -- mem )
+ dup anchor @ = IF dup @ anchor ! THEN ;
-': unlink ( mem -- ) setanchor @links 2dup ! swap cell+ ! ;'
+: unlink ( mem -- ) setanchor @links 2dup ! swap cell+ ! ;
-': allocate ( size -- mem ior )
- 3 #, cells max dup >r fits? ?dup 0= IF r> -8 #, unnest THEN ( "dictionary overflow" )
+: allocate ( size -- mem ior )
+ 3 cells max dup >r fits? ?dup 0= IF r> -8 unnest THEN ( "dictionary overflow" )
addr&size r@ - dup waste u<
IF drop dup @ over unlink over addr&size use
- ELSE 2 #, cells - over r@ use
+ ELSE 2 cells - over r@ use
over above dup rot release
2dup swap @links link THEN
- r> drop anchor ! 0 #, ;'
+ r> drop anchor ! 0 ;
-': free ( mem -- ior )
- addr&size over 2 #, cells - @ dup 0<
- IF #max and 2 #, cells + rot over - rot rot +
+: free ( mem -- ior )
+ addr&size over 2 cells - @ dup 0<
+ IF #max and 2 cells + rot over - rot rot +
ELSE drop over anchor @ dup cell+ @ link THEN
2dup + cell+ dup @ dup 0<
- IF #max and swap cell+ unlink + 2 #, cells + release 0 #, unnest THEN
- 2drop release 0 #, ;'
+ IF #max and swap cell+ unlink + 2 cells + release 0 unnest THEN
+ 2drop release 0 ;
-': resize ( mem newsize -- mem' ior )
+: resize ( mem newsize -- mem' ior )
over swap over size 2dup >
IF ( mem mem size newsize ) swap allocate ?dup IF >r drop 2drop r> unnest THEN
dup >r swap move free r> swap unnest THEN
- 2drop drop ;'
+ 2drop drop ;
-': empty-memory ( addr size -- )
- >r cell+ dup anchor ! dup 2 #, cells use dup 2dup link
+: empty-memory ( addr size -- )
+ >r cell+ dup anchor ! dup 2 cells use dup 2dup link
dup above swap over dup link
- dup r> 7 #, cells - release above 1 #, cells - 0 #, swap ! ;'
+ dup r> 7 cells - release above 1 cells - 0 swap ! ;
-\ : ?memory ( -- ) anchor @
-\ cr ." ->: " BEGIN cr dup u. ." : " addr&size u. @ dup anchor @ = UNTIL
-\ cr ." <-: " BEGIN cr dup u. ." : " addr&size u. cell+ @ dup anchor @ = UNTIL
-\ drop ;
+: init ( -- )
+ here 1000 ( chars ) dup allot empty-memory ;
-': init ( -- )
- here 1000 #, ( chars ) dup allot empty-memory ;'
+: alloc ( u -- addr )
+ allocate throw ;
-': alloc ( u -- addr )
- allocate throw ;'
+: dispose ( addr -- )
+ free throw ;
-': dispose ( addr -- )
- free throw ;'
-\ Utility words for debugging
-\ ----------------------------
-\ hex number output
-
-': 1- 1 #, - ;'
-': 1+ 1 #, + ;'
-': nip swap drop ;'
-
-': .hexdigit ( n -- ) dup 9 #, > IF lit [ 'A' # 10 # - , ] ELSE '0' #, THEN + emit ;'
-
-\ ': 2* ( x1 -- x2 ) dup + ;'
-
-': space 32 #, emit ;'
-
-': cr 10 #, emit 13 #, emit ;'
-
-
-\ if we don't have u2/ but only 2* and 0< we need to implement u2/ with a loop. Candidate for primitive
-': u2/ ( x1 -- x2 )
- 0 #, 8 #, CELLS 1- BEGIN ?dup WHILE >r 2* over 0< IF 1+ THEN >r 2* r> r> 1- REPEAT nip ;'
-
-': odd? ( x1 -- f ) dup u2/ 2* = 0= ;'
-
-': 2/mod ( x1 -- x2 r ) \ swapped results
- dup u2/ swap odd? negate ;'
-
-': 16/mod ( x -- x r ) \ swapped results
- 2/mod >r 2/mod >r 2/mod >r 2/mod 2* r> + 2* r> + 2* r> + ;'
-
-': #### ( x -- )
- 16/mod >r 16/mod >r 16/mod >r 16/mod >r 16/mod >r 16/mod >r 16/mod >r
- .hexdigit r> .hexdigit r> .hexdigit r> .hexdigit r> .hexdigit
- r> .hexdigit r> .hexdigit r> .hexdigit space ;'
-
-': (.) ( x -- )
- ?dup IF 16/mod >r (.) r> .hexdigit THEN ;'
-
-': u. ( x -- )
- ?dup IF (.) ELSE '0' #, emit THEN space ;'
-
-': . ( n -- ) dup 0< IF '-' #, emit negate THEN u. ;'
-
\ Dynamic Memory smoke test
\ -------------------------------------
+: ?memory ( -- ) anchor @
+ cr ." ->: " BEGIN cr dup u. ." : " addr&size u. @ dup anchor @ = UNTIL
+ cr ." <-: " BEGIN cr dup u. ." : " addr&size u. cell+ @ dup anchor @ = UNTIL
+ drop ;
+
#max u. \ 7FFFFFFF
#free u. \ 80000000
init
-cr here . \ end address roughly 1000 abover
+cr here . \ end address roughly 1000 above
+
+?memory cr
+
+cr 100 allocate . dup . free . \ ior 0, allocate at address1, ior 0
+cr 100 allocate . dup . \ ior 0, allocated at same address1
+cr 100 allocate . dup . free . \ ior 0, allocated at new address2 roughly 100 above, ior 0
+cr 100 allocate . dup . \ ior 0, allocated at again at address2
+
+cr ?memory
-cr 100 # allocate . dup . free . \ ior 0, allocate at address1, ior 0
-cr 100 # allocate . dup . \ ior 0, allocated at same address1
-cr 100 # allocate . dup . free . \ ior 0, allocated at new address2 roughly 100 above, ior 0
-cr 100 # allocate . dup . \ ior 0, allocated at again at address2
cr free . \ free address2 -> ior 0
cr free . \ free address1 -> ior 0
-cr 100 # allocate . dup . free . \ ior 0, allocated at address1, ior 0
+cr 100 allocate . dup . free . \ ior 0, allocated at address1, ior 0
+
+?memory
-end
+END
public / preForth.git / commitdiff