Add dynamic memory, execute and compile, do h@

diff --git a/preForth/dynamic.seedsource b/preForth/dynamic.seedsource
new file mode 100644 (file)
index 0000000..23434c2
--- /dev/null
+++ b/preForth/dynamic.seedsource
@@ -0,0 +1,176 @@
+\ Klaus Schleisiek's dynamic memory allocation (FORML'88) seedForth-version uh 2018-06-20
+
+program dynamic.seed
+
+\ extend seedForth core with words required by dynamic memory
+\ -------------------------------------
+
+': _variable ( x -- )  create 0 #, , [ does> ]    ;'  \ a seedForth defining word
+: Variable  ( <name> -- ) fun: _variable ; \ macro
+
+': doconst ( x -- ) [ does> ] @ ;'  \ a does>  w/o creat path sets behavour
+: Constant  ( <name> x -- ) fun: create , doconst ; \ macro
+
+': over ( x1 x2 -- x1 x2 x1 )  >r dup r> swap ;'
+
+': 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 ;'
+
+': 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> dup >r ;
+
+': cell+ ( addr1 -- addr2 )  1 #, cells + ;'
+
+': 2* ( x1 -- x2 ) dup + ;'
+': 256* ( x1 -- x2 ) 2* 2* 2* 2* 2* 2* 2* 2* ;'
+    
+
+\ dynamic memory
+\ -------------------------------------
+
+Variable anchor
+
+50 # Constant waste
+
+128 # 256* 256* 256* ( 32bit ) Constant #free  \ sign bit
+#free 1 # - ( 31bit ) Constant #max
+
+
+': size ( mem -- size ) 1 #, cells - @ #max and ;'
+
+': addr&size ( mem -- mem size ) dup size ;'
+
+': above ( mem -- >mem )   addr&size + 2 #, cells + ;'
+
+': use ( mem size -- )
+    dup >r swap  2dup 1 #, cells - !  r> #max and + ! ;'
+
+': release ( mem size -- )   #free or use ;'
+
+': fits? ( size -- mem | false ) >r anchor @
+    BEGIN addr&size  r@ u< 0=
+         IF r> drop unnest THEN
+         @ dup anchor @ =
+    UNTIL 0= r> drop ;'
+
+': link ( mem >mem <mem -- )
+    >r 2dup cell+ !  over !  r> 2dup !  swap cell+ ! ;'
+
+': @links ( mem -- <mem mem> )  dup @  swap cell+ @ ;'
+
+': setanchor ( mem -- mem ) 
+    dup anchor @ = IF  dup @ anchor ! THEN ;'
+
+': 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" )
+    addr&size r@ -  dup waste u<
+    IF  drop  dup @ over unlink  over addr&size use
+    ELSE 2 #, cells -   over r@ use
+         over above   dup rot release
+         2dup swap @links link THEN
+    r> drop  anchor ! 0 #, ;'
+
+': 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 #, ;'
+
+': 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 ;'
+
+': 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 ! ;'
+
+\ : ?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 ;
+
+200 # dup  dup + dup + + Constant 1000  \ seedForth stunt to get a large number
+
+': init ( -- )
+    here 1000 ( ! )  ( chars ) dup allot empty-memory ;'
+
+\ 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 ;'
+
+
+\ 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
+\ -------------------------------------
+
+#max u.  \ 7FFFFFFF
+#free u. \ 80000000
+
+here .  \ base address
+
+init
+
+here .  \ end address  roughly 1000 abover
+
+100 # allocate . dup . free .  \ ior 0, allocate at address1, ior 0
+100 # allocate . dup .         \ ior 0, allocated at same address1
+100 # allocate . dup . free .  \ ior 0, allocated at new address2 roughly 100 above, ior 0
+100 # allocate . dup .         \ ior 0, allocated at again at address2
+free .   \ free address2 -> ior 0
+free .   \ free address1 -> ior 0
+100 # allocate . dup . free .  \ ior 0, allocated at address1, ior 0
+
+end

diff --git a/preForth/seedForth-i386.pre b/preForth/seedForth-i386.pre
index 49fd358..ec57277 100644 (file)
--- a/preForth/seedForth-i386.pre
+++ b/preForth/seedForth-i386.pre
@@ -87,8 +87,9 @@ main0: mov esi, main1
 
 main1: DD _cold
        DD _bye  
-  
-_nest:  lea ebp, [ebp-4]
+
+_nest:
+_enter:  lea ebp, [ebp-4]
         mov [ebp], esi
         lea esi, [eax+4]
         next
@@ -181,7 +182,7 @@ zless1: push eax
         next
 ;
 
-code ?exit ( f -- )
+code ?exit ( f -- ) \  high level:  IF exit THEN
         pop eax
         or eax, eax
         jz qexit1
@@ -212,6 +213,22 @@ code - ( x1 x2 -- x3 )
         next
 ;
 
+code or ( x1 x2 -- x3 )
+        pop edx
+        pop eax
+        or eax, edx
+        push eax
+        next
+;
+
+code and ( x1 x2 -- x3 )
+        pop edx
+        pop eax
+        and eax, edx
+        push eax
+        next
+;
+
 code unnest ( -- )
         mov esi,[ebp]
         lea ebp,[ebp+4]
@@ -253,7 +270,7 @@ code c! ( c c-addr -- )
         next
 ;
 
-code execute ( xt -- ) \ native code: >r :
+code invoke ( addr -- ) \ native code: >r ;
         pop eax
         jmp dword [eax]
 ;
@@ -320,14 +337,23 @@ code depth ( -- n )
 : c, ( c -- )
    here   1 allot c! ;
 
+: compile, ( x -- )
+   h@ , ;
+
+: execute ( x -- )
+   h@ invoke ;
+
 : interpreter ( -- )
-   key h@ execute   tail interpreter ;
+   key execute   tail interpreter ;
 
 : compiler ( -- )
-   key ?dup 0= ?exit h@ ,   tail compiler ;
+   key ?dup 0= ?exit compile, tail compiler ;
+
+: new ( -- )
+   here h,  lit enter , ;
 
 : fun ( -- )
-   here h,  lit nest ,  compiler ;
+   new compiler ;
 
 
 : create ( -- )
@@ -385,6 +411,10 @@ code depth ( -- n )
    lit does>       h, \ 36  24
    lit cold        h, \ 37  25
    lit depth       h, \ 38  26
+   lit compile,    h, \ 39  27
+   lit new         h, \ 40  28
+   lit and         h, \ 41  29
+   lit or          h, \ 42  2A
    tail interpreter ;
 
 pre

diff --git a/preForth/seedForth-tokenizer.fs b/preForth/seedForth-tokenizer.fs
index f9e0af8..08d7eb0 100644 (file)
--- a/preForth/seedForth-tokenizer.fs
+++ b/preForth/seedForth-tokenizer.fs
@@ -32,7 +32,8 @@ FUN: negate    FUN: +           FUN: 0=        FUN: ?dup              \ 14 15 16 17
 FUN: cells     FUN: +!          FUN: h@        FUN: h,                 \ 18 19 1A 1B
 FUN: here      FUN: allot       FUN: ,         FUN: c,                 \ 1C 1D 1E 1F
 FUN: fun       FUN: interpreter FUN: compiler  FUN: create             \ 20 21 22 23
-FUN: does>     FUN: cold        FUN: depth                             \ 24 25 26
+FUN: does>     FUN: cold        FUN: depth     FUN: compile,   \ 24 25 26 27
+FUN: new       FUN: and         FUN: or
 
 : [ ( -- )  0 SUBMIT ;
 : ] ( -- )  compiler ;

diff --git a/preForth/seedForthDemo.seedsource b/preForth/seedForthDemo.seedsource
index ab26ffc..47ce4bb 100644 (file)
--- a/preForth/seedForthDemo.seedsource
+++ b/preForth/seedForthDemo.seedsource
@@ -9,8 +9,16 @@
 \ cat seedForthDemo.seed | ./seedForth
 \
 
+
 program seedForthDemo.seed
 
+
+
+\ : compiler ( -- )
+\    key ?dup 0= ?exit compile, tail compiler ;
+
+
+
 'o' # 'k' # \ push stack marker. Used eventually below.
 
 ': ?ok ( o k -- o k )  10 #, emit  >r dup emit r> dup  emit ;'
@@ -215,21 +223,26 @@ cr #person u.  \ size of structure
 
 \ Defered words
 
-': dodefer ( -- )  [ does> ] @ execute ;'
-: Defer  ( <name> -- ) fun: create ] star [  dodefer ;    \ macro, star is default behaviour
+': ' ( --  x )  key ;'
+
+' star constant 'star  cr 'star .
 
-': >body ( xt -- body )  1 #, cells + ;'
+': dodefer ( -- )  [ does> ] @ execute ;'
+: Defer  ( <name> -- ) fun: create 'star , dodefer ;    \ macro, star is default behaviour
 
-': ' ( --  x )  key h@ ;'
+': >body ( xt -- body )  h@  1 #, cells + ;'
 
 ': is ( xt -- )  ' >body ! ;'
 
+cr ' dash dup .  execute            \ get execution token of definition
+cr
 
 Defer d1
 
+\ ' star is d1
+
 cr d1 d1 d1 \ display stars
 
-cr ' dash dup .  execute            \ get execution token of definition
 
 ' dash is d1 \ set behaviour of deferred word
 
@@ -287,6 +300,13 @@ t{ 3 # 4 # + -> 7 # }t
 t{ 3 # 4 # + -> 8 # }t
 t{ 3 # 4 # + -> 1 # 2 # }t
 
+fun: twice
+new  key dup compile,  key + compile,  key unnest compile,
+
+t{ 2 # twice -> 4 # }t
+
+cr 2 # twice .
+
 
 cr  'd' # emit 'o' # emit 'n' # emit 'e' # emit cr