From 0a9bf7ab452f69bf8bfb5ef5b1c67eededf7d689 Mon Sep 17 00:00:00 2001
From: Ulrich Hoffmann <uho@xlerb.de>
Date: Fri, 4 Oct 2019 12:26:28 +0200
Subject: [PATCH] Define common names for allocation, cleanup

---
 preForth/dynamic.seedsource       |  7 +++++
 preForth/seedForthDemo.seedsource | 45 ++++++++++++++++++++++++++-----
 2 files changed, 46 insertions(+), 6 deletions(-)

diff --git a/preForth/dynamic.seedsource b/preForth/dynamic.seedsource
index 53636c3..ed727c7 100644
--- a/preForth/dynamic.seedsource
+++ b/preForth/dynamic.seedsource
@@ -110,6 +110,13 @@ Variable anchor
 ': init ( -- )
     here 1000 #,  ( chars ) dup allot empty-memory ;'
 
+': alloc ( u -- addr )
+     allocate throw ;'
+
+': dispose ( addr -- )
+     free throw ;'
+
+
 \ Utility words for debugging
 \ ----------------------------
 \ hex number output
diff --git a/preForth/seedForthDemo.seedsource b/preForth/seedForthDemo.seedsource
index 5918f4b..ac546c4 100644
--- a/preForth/seedForthDemo.seedsource
+++ b/preForth/seedForthDemo.seedsource
@@ -162,7 +162,7 @@ cr V @ u.  \  get value:  4
 : Value ( <name> x -- )  fun: _value ; \ macro 2)
 
 
-': _variable ( x -- )  create 0 #, , does>  ;'  \ a seedForth defining word
+': _variable ( -- )  create  0 #, ,  does>  ;'  \ a seedForth defining word
 : Variable  ( <name> -- ) fun: _variable ; \ macro
 
 fun: V1  5 # _value
@@ -174,7 +174,7 @@ fun: V2  _variable
 7 # V2 +!  V2 @ u.   8 # V2 !  V2 @ u.  \ fetch and store value: 7 8
 
 
-': doconst ( x -- ) does> @ ;'  \ a does>  w/o creat path sets behavour
+': doconst ( -- ) does> @ ;'  \ a does>  w/o creat path sets behavour
 : Constant  ( <name> x -- ) fun: create , doconst ; \ macro
 
 fun: nine create
@@ -338,12 +338,45 @@ t{ 1 # negate 0< -> -1 # }t
 t{ 2 # negate 0< -> -1 # }t
 
 
-': greet ( -- )
-    cr s" a string literal"  ;' 
+': greeting ( -- )  s" a string literal"  ;' 
 
-t{ greet nip -> 16 # }t
+t{ greeting nip -> 16 # }t
 
 
-cr  'd' # emit 'o' # emit 'n' # emit 'e' # emit cr
+': compare ( c-addr1 u1 c-addr2 u2 -- n )
+    rot 
+    BEGIN \ ( c-addr1 c-addr2 u1 u2 )
+      over 
+    WHILE
+      dup
+    WHILE
+      >r >r  over c@ over c@ - ?dup IF 0< dup + 1 + nip nip r> drop r> drop unnest THEN
+      1+ swap 1+ swap
+      r> 1- r> 1-
+    REPEAT
+      -1
+    ELSE
+      dup 0= IF 0 ELSE 1 THEN
+    THEN >r 2drop 2drop r> ;'
+
+t{ wrong count  wrong count compare     ->  0 }t
+t{ wrong count  incorrect count compare -> -1 }t  
+
+': .s ( i*x -- i*x )  
+    depth 0= ?exit  >r .s r> dup . ;'
+
+
+': alloc ( u -- addr )
+    here swap allot ;'
+
+': dispose ( addr -- )
+    drop ;'
+
+
+
+\ -----------------------------------------------
+
+': done ( -- )  cr s" done" type cr ;' done
+\ cr  'd' # emit 'o' # emit 'n' # emit 'e' # emit cr
 
 end
-- 
2.34.1