From: Tim Vaughan <tgvaughan@gmail.com>
Date: Wed, 12 Oct 2016 08:34:34 +0000 (+1300)
Subject: Added UNLOOP, COMPARE and TOLOWER.
X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=commitdiff_plain;h=3a6f6d8ce275a51f67a8fde0a89ac9deb0020217;p=forth.jl.git

Added UNLOOP, COMPARE and TOLOWER.
---

diff --git a/src/forth.jl b/src/forth.jl
index 9beb814..9939c9c 100644
--- a/src/forth.jl
+++ b/src/forth.jl
@@ -1134,42 +1134,18 @@ IMMEDIATE_CFA = defPrimWord("IMMEDIATE", () -> begin
     return NEXT
 end, flags=F_IMMED)
 
-CODE_CFA = defPrimWord("CODE", () -> begin
-    pushPS(32)
-    callPrim(mem[WORD_CFA])
-    callPrim(mem[HEADER_CFA])
-
-    exprString = "() -> begin\n"
-    while true
-        if mem[TOIN] >= mem[NUMTIB]
-            exprString = string(exprString, "\n")
-            if currentSource() == STDIN
-                println()
-            end
-
-            pushPS(TIB)
-            pushPS(160)
-            callPrim(mem[EXPECT_CFA])
-            mem[NUMTIB] = mem[SPAN]
-            mem[TOIN] = 0
-        end
-
-        pushPS(32)
-        callPrim(mem[WORD_CFA])
-        cAddr = popPS()
-        thisWord = getString(cAddr+1, mem[cAddr])
-
-        if uppercase(thisWord) == "END-CODE"
-            break
-        end
-
-        exprString = string(exprString, " ", thisWord)
-    end
-    exprString = string(exprString, "\nreturn NEXT\nend")
-
-    func = eval(parse(exprString))
-    dictWrite(defPrim(func))
+# ( addr n -- primAddr )
+CREATE_PRIM_CFA = defPrimWord("CREATE-PRIM", () -> begin
+    len = popPS()
+    addr = popPS()
+    
+    exprString = string("() -> begin\n",
+                        getString(addr, len), "\n",
+                        "return NEXT\n",
+                        "end")
+    func = eval(parse(expString))
 
+    pushPS(defPrim(func))
     return NEXT
 end)
 
diff --git a/src/lib_2_control.4th b/src/lib_2_control.4th
index beb232d..e565d6b 100644
--- a/src/lib_2_control.4th
+++ b/src/lib_2_control.4th
@@ -99,6 +99,11 @@
         [COMPILE] ?LEAVE
 ;
 
+\ Clean up return stack
+: UNLOOP IMMEDIATE
+        ['] RDROP , ['] RDROP , ['] RDROP ,
+;
+
 : +LOOP IMMEDIATE
 
         ['] DUP , \ Store copy of increment
diff --git a/src/lib_6_strings.4th b/src/lib_6_strings.4th
index 16d8001..aec678b 100644
--- a/src/lib_6_strings.4th
+++ b/src/lib_6_strings.4th
@@ -92,6 +92,39 @@
 : COUNT ( addr1 -- addr2 n )
         DUP 1+ SWAP @ ;
 
+( Compares two strings, returns 0 if identical. )
+: COMPARE ( addr1 n1 addr2 n2 -- res )
+    rot 2dup <> if
+        2drop 2drop 1 exit
+    then
+    
+    drop
+
+    0 do
+        2dup i + @ swap i + @ <> if
+            unloop 2drop 1 exit
+        then
+    loop
+
+    2drop 0
+;
+
+( Converts a string to lower case. )
+: TOLOWER ( addr n -- )
+    0 do
+        dup i + @ dup dup ( addr char char char )
+        [char] A >=
+        swap [char] Z <= and if
+            [char] A - [char] a +
+            over i + !
+        else
+            drop
+        then
+    loop
+
+    drop
+;
+
 ( Abort if flag is true. )
 : ABORT" IMMEDIATE  ( flag -- )
         [COMPILE] S"