From 06a4674317d51d4e79cdcc7ad3c71e8a32913624 Mon Sep 17 00:00:00 2001
From: Virgil Dupras <hsoft@hardcoded.net>
Date: Sun, 10 May 2020 09:37:36 -0400
Subject: [PATCH] ti84: implement a-lock

There's a bug where the first char after a-lock isn't a-modded. I
have troubles figuring it out for now. It feels like deja vu. I
think I had the same problem with asm.
---
 blk/568               |  4 ++++
 blk/570               | 14 ++++++++++----
 recipes/ti84/xcomp.fs |  3 ++-
 3 files changed, 16 insertions(+), 5 deletions(-)

diff --git a/blk/568 b/blk/568
index 4db2b0c..6847457 100644
--- a/blk/568
+++ b/blk/568
@@ -7,3 +7,7 @@ CREATE _atbl
     0x20 C, 'Y' C, 'T' C, 'O' C, 'J' C, 'E' C, 'B' C, 0 C,
     0 C, 'X' C, 'S' C, 'N' C, 'I' C, 'D' C, 'A' C, 0x80 C,
     0 C, 0 C, 0 C, 0 C, 0 C, 0x81 ( 2nd ) C, 0 C, 0x7f C,
+: _2nd@ 0 [ KBD_MEM LITN ] BIT@ ;
+: _2nd! 0 [ KBD_MEM LITN ] BIT! ;
+: _alock@ 1 [ KBD_MEM LITN ] BIT@ ;
+: _alock^ _alock@ NOT 1 [ KBD_MEM LITN ] BIT! ;
diff --git a/blk/570 b/blk/570
index 63da689..a71f0ff 100644
--- a/blk/570
+++ b/blk/570
@@ -1,6 +1,12 @@
+: _tbl^ ( swap input tbl )
+    _atbl = IF _dtbl ELSE _atbl THEN ;
 : (key)
-    _dtbl 0 ( dummy ) BEGIN ( tbl 0 )
-        DROP DUP ( tbl ) _gti + C@
-        DUP 0x80 = IF ( alpha ) 2DROP _atbl 0 THEN
-    DUP UNTIL ( tbl c -- loop if null ) SWAP DROP
+    0 _2nd! 0 ( lastchr ) BEGIN
+        _alock@ IF _atbl ELSE _dtbl THEN
+        OVER 0x80 ( alpha ) =
+            IF _tbl^ _2nd@ IF _alock^ THEN THEN
+        SWAP 0x81 = _2nd!
+        _gti + C@
+    DUP 0 0x80 >< UNTIL ( loop if not in range )
     _wait ;
+: KBD$ 0 [ KBD_MEM LITN ] C! ;
diff --git a/recipes/ti84/xcomp.fs b/recipes/ti84/xcomp.fs
index fc14eb1..d7c58f1 100644
--- a/recipes/ti84/xcomp.fs
+++ b/recipes/ti84/xcomp.fs
@@ -1,6 +1,7 @@
 0x8000 CONSTANT RAMSTART
 0xb000 CONSTANT RS_ADDR
 RAMSTART 0x70 + CONSTANT LCD_MEM
+RAMSTART 0x72 + CONSTANT KBD_MEM
 0x01 CONSTANT KBD_PORT
 212 LOAD  ( z80 assembler )
 262 LOAD  ( xcomp )
@@ -25,6 +26,6 @@ PC ORG @ 8 + !
 422 437 XPACKR ( core )
 558 560 XPACKR ( LCD high )
 438 451 XPACKR ( print fmt readln )
-," : _ LCD$ (ok) RDLN$ ; _ "
+," : _ LCD$ KBD$ (ok) RDLN$ ; _ "
 ORG @ 256 /MOD 2 PC! 2 PC!
 H@ 256 /MOD 2 PC! 2 PC!