From ade7d9eb69fea4e2e77194cc722e7e187e219c0a Mon Sep 17 00:00:00 2001
From: ketmar <ketmar@ketmar.no-ip.org>
Date: Tue, 11 Aug 2020 15:57:21 +0000
Subject: [PATCH] urforth: added "STRTO"

FossilOrigin-Name: efb5e0ab9d6c831b52492d825352c203e1386317b4663577bc85b671b33ca977
---
 src/urforth.c | 64 +++++++++++++++++++++++++++++++++++++++++++++++++++++------
 1 file changed, 58 insertions(+), 6 deletions(-)

diff --git a/src/urforth.c b/src/urforth.c
index f791d33..a1fa5cb 100644
--- a/src/urforth.c
+++ b/src/urforth.c
@@ -2609,6 +2609,25 @@ UFWORD(ZX_TO_IMM) {
   }
 }
 
+// ZX-STRTO
+UFWORD(ZX_STRTO) {
+  char *wname = ufePopStrLit();
+  ForthWord *fwdr = findForthWord(wname);
+  if (!fwdr) ufeFatal("forth word `%s` not found", wname);
+  if (fwdr->wtype != FWT_DEFER && fwdr->wtype != FWT_VALUE) ufeFatal("forth word `%s` is not VALUE/DEFER", wname);
+  free(wname);
+  if (ufeGetState()) {
+    // compiling
+    // LITTO!
+    ufeCompileZXWord("LITTO!");
+    // emit pfa literal
+    ufeZXEmitU16(fwdr->cfa+3u);
+  } else {
+    // interpreting
+    putWord(fwdr->cfa+3u, ufePop()&0xffffU);
+  }
+}
+
 // ZX-'
 UFWORD(ZX_TICKCFA_IMM) {
   const char *wname = ufeZXWORD(' ');
@@ -2762,9 +2781,7 @@ UFWORD(NATIVE_VARBIN) {
   free(fname);
 }
 
-static UForthWord *ufeNTWord (void) {
-  ufePush(32); UFCALL(WORD);
-  UFCALL(COUNT);
+static UForthWord *ufeNTWordAddrCount (void) {
   uint32_t count = ufePop();
   uint32_t addr = ufePop();
   UForthWord *fw = ufeNFind(addr, count);
@@ -2776,7 +2793,13 @@ static UForthWord *ufeNTWord (void) {
   return fw;
 }
 
-// NATIVE-TO_IMM
+static UForthWord *ufeNTWord (void) {
+  ufePush(32); UFCALL(WORD);
+  UFCALL(COUNT);
+  return ufeNTWordAddrCount();
+}
+
+// NATIVE-TO
 UFWORD(NATIVE_TO_IMM) {
   UForthWord *fw = ufeNTWord();
   if (fw->cfa != &ufeDoValue && fw->cfa != &ufeDoDefer) ufeFatal("UFE word `%s` is not VALUE/DEFER", fw->name);
@@ -2791,7 +2814,23 @@ UFWORD(NATIVE_TO_IMM) {
   }
 }
 
-// NATIVE_TICKCFA_IMM
+// NATIVE-STRTO
+// ( value addr count -- )
+UFWORD(NATIVE_STRTO) {
+  UForthWord *fw = ufeNTWordAddrCount();
+  if (fw->cfa != &ufeDoValue && fw->cfa != &ufeDoDefer) ufeFatal("UFE word `%s` is not VALUE/DEFER", fw->name);
+  if (ufeGetState()) {
+    // compiling
+    // literal
+    ufeCompileNativeLiteral(fw->pfa);
+    ufeCompileNativeWord("!");
+  } else {
+    // interpreting
+    ufeImgPutU32(fw->pfa, ufePop());
+  }
+}
+
+// NATIVE-'
 UFWORD(NATIVE_TICKCFA_IMM) {
   ufePush(32); UFCALL(WORD);
   UFCALL(COUNT);
@@ -2814,7 +2853,7 @@ UFWORD(NATIVE_TICKCFA_IMM) {
   }
 }
 
-// NATIVE_TICKPFA_IMM
+// NATIVE-'PFA
 UFWORD(NATIVE_TICKPFA_IMM) {
   ufePush(32); UFCALL(WORD);
   UFCALL(COUNT);
@@ -2889,6 +2928,8 @@ UFWORD_2MODES_X(DP_PEEK, DP@)
 UFWORD_2MODES_X(DP_POKE, DP!)
 // TO
 UFWORD_2MODES_IMM(TO_IMM)
+// STRTO
+UFWORD_2MODES(STRTO)
 // '
 UFWORD_2MODES_IMM(TICKCFA_IMM)
 // 'PFA
@@ -3525,6 +3566,14 @@ static void ufeDefineMisc (void) {
   ufeNumber(10); UFC(BASE); UFC(!);
   ufeDefineDone();
 
+  ufeDefine("0!");
+  UFC(0) UFC(SWAP) UFC(!)
+  ufeDefineDone();
+
+  ufeDefine("1!");
+  UFC(1) UFC(SWAP) UFC(!)
+  ufeDefineDone();
+
   ufeDefine("+!");
   UFC(DUP) UFC(@) UFC(ROT) UFC(+) UFC(SWAP) UFC(!)
   ufeDefineDone();
@@ -3850,6 +3899,7 @@ static void ufeInit (void) {
   UFWORDX("ZX-DP@", ZX_DP_PEEK);
   UFWORDX("ZX-DP!", ZX_DP_POKE);
   UFWORDX_IMM("ZX-TO", ZX_TO_IMM);
+  UFWORDX_IMM("ZX-STRTO", ZX_STRTO);
   UFWORDX_IMM("ZX-'", ZX_TICKCFA_IMM);
   UFWORDX_IMM("ZX-'PFA", ZX_TICKPFA_IMM);
 
@@ -3865,6 +3915,7 @@ static void ufeInit (void) {
   UFWORDX("NATIVE-DP@", NATIVE_DP_PEEK);
   UFWORDX("NATIVE-DP!", NATIVE_DP_POKE);
   UFWORDX_IMM("NATIVE-TO", NATIVE_TO_IMM);
+  UFWORDX_IMM("NATIVE-STRTO", NATIVE_STRTO);
   UFWORDX_IMM("NATIVE-'", NATIVE_TICKCFA_IMM);
   UFWORDX_IMM("NATIVE-'PFA", NATIVE_TICKPFA_IMM);
 
@@ -3880,6 +3931,7 @@ static void ufeInit (void) {
   UFWORDX_IMM("DP@", DP_PEEK);
   UFWORDX_IMM("DP!", DP_POKE);
   UFWORDX_IMM("TO", TO_IMM);
+  UFWORDX_IMM("STRTO", STRTO);
   UFWORDX_IMM("'", TICKCFA_IMM);
   UFWORDX_IMM("'PFA", TICKPFA_IMM);
 
-- 
2.11.4.GIT