From 2bf1634aa4861a291eba9bfc88ae80a81bf9f8fb Mon Sep 17 00:00:00 2001
From: Clyne Sullivan <clyne@bitgloo.com>
Date: Mon, 20 Feb 2023 09:36:33 -0500
Subject: text words; control word fixes
---
compat.txt | 18 +++++++++---------
core.fth | 51 ++++++++++++++++++++++++++++++++-------------------
2 files changed, 41 insertions(+), 28 deletions(-)
diff --git a/compat.txt b/compat.txt
index b7b780f..c5d2b56 100644
--- a/compat.txt
+++ b/compat.txt
@@ -15,7 +15,7 @@ yes 6.1.0140 +LOOP
yes 6.1.0150 ,
yes 6.1.0160 -
yes 6.1.0180 .
- 6.1.0190 ."
+yes 6.1.0190 ."
yes 6.1.0230 /
6.1.0240 /MOD
yes 6.1.0250 0<
@@ -58,11 +58,11 @@ yes 6.1.0860 C,
yes 6.1.0870 C@
yes 6.1.0880 CELL+
yes 6.1.0890 CELLS
- 6.1.0895 CHAR
+yes 6.1.0895 CHAR
yes 6.1.0897 CHAR+
yes 6.1.0898 CHARS
6.1.0950 CONSTANT
- 6.1.0980 COUNT
+yes 6.1.0980 COUNT
yes 6.1.0990 CR
6.1.1000 CREATE
yes 6.1.1170 DECIMAL
@@ -114,11 +114,11 @@ yes 6.1.2162 RSHIFT
6.1.2214 SM/REM
6.1.2216 SOURCE
yes 6.1.2220 SPACE
- 6.1.2230 SPACES
+yes 6.1.2230 SPACES
yes 6.1.2250 STATE
yes 6.1.2260 SWAP
yes 6.1.2270 THEN
- 6.1.2310 TYPE
+yes 6.1.2310 TYPE
6.1.2320 U.
6.1.2340 U<
6.1.2360 UM*
@@ -127,10 +127,10 @@ yes 6.1.2270 THEN
yes 6.1.2390 UNTIL
6.1.2410 VARIABLE
yes 6.1.2430 WHILE
- 6.1.2450 WORD
+yes 6.1.2450 WORD
yes 6.1.2490 XOR
- 6.1.2500 [
+yes 6.1.2500 [
yes 6.1.2510 [']
- 6.1.2520 [CHAR]
- 6.1.2540 ]
+yes 6.1.2520 [CHAR]
+yes 6.1.2540 ]
diff --git a/core.fth b/core.fth
index 16610ba..eb41948 100644
--- a/core.fth
+++ b/core.fth
@@ -29,8 +29,18 @@
: char+ 1+ ;
: chars ;
-: 2r> r> r> swap ;
-: 2>r swap >r >r ;
+: base 0 ;
+: state 2 ;
+: decimal 1 1+ base ! 1010 base ! ;
+
+: postpone 1 4 ! ; imm
+: ['] ' postpone literal ; imm
+: [ 0 state ! ; imm
+: ] 1 state ! ;
+
+: 2r> ['] r> , ['] r> , ['] swap , ; imm
+: 2>r ['] swap , ['] >r , ['] >r , ; imm
+: r@ ['] r> , ['] dup , ['] >r , ; imm
: 2! swap over ! cell+ ! ;
: 2@ dup cell+ @ swap @ ;
@@ -40,29 +50,21 @@
: 0< 0 < ;
: <= - 1- 0< ;
: > <= 0= ;
-
-: base 0 ;
-: state 2 ;
-: decimal 1 1+ base ! 1010 base ! ;
-
-: postpone 1 4 ! ; imm
-: ['] ' postpone literal ; imm
-
-: r@ ['] r> , ['] dup , ['] >r , ; imm
+: <> = 0= ;
: if ['] _jmp0 , here 0 , ; imm
: then here swap ! ; imm
: else ['] _jmp , here 0 , here rot ! ; imm
-: begin here 0 ; imm
-: while 1+ postpone if swap ; imm
-: repeat ['] _jmp , if swap , postpone then else , then ; imm
-: until drop ['] _jmp0 , , ; imm
+: begin 0 here ; imm
+: while swap 1+ swap postpone if -rot ; imm
+: repeat ['] _jmp , , if postpone then then ; imm
+: until ['] _jmp0 , , drop ; imm
-: do ['] swap , ['] >r , ['] >r , here ; imm
-: +loop ['] r> , ['] r> , ['] swap , ['] rot , ['] + , ['] 2dup ,
- ['] swap , ['] >r , ['] >r , ['] - , ['] 0= ,
- ['] _jmp0 , , ['] r> , ['] r> , ['] swap , ['] 2drop , ; imm
+: do postpone 2>r here ; imm
+: +loop postpone 2r> ['] rot , ['] + , ['] 2dup ,
+ postpone 2>r ['] - , ['] 0= , ['] _jmp0 , ,
+ postpone 2r> ['] 2drop , ; imm
: loop 1 postpone literal postpone +loop ; imm
: i postpone r@ ; imm
@@ -81,6 +83,7 @@
: cr 9 emit ;
: bl 32 ;
: space bl emit ;
+: spaces begin dup 0 > while space 1- repeat ;
: ?dup dup if dup then ;
@@ -88,3 +91,13 @@
: abs dup 0< if negate then ;
: min 2dup <= if drop else nip then ;
: max 2dup <= if nip else drop then ;
+
+: word here -1 cells over ! dup cell+ rot begin key 2dup <> while
+ 2 pick c! swap char+ swap repeat
+ 2drop over - over +! ;
+: count dup cell+ swap @ ;
+: char bl word cell+ c@ ;
+: [char] char postpone literal ; imm
+
+: type begin dup 0 > while swap dup c@ emit char+ swap 1- repeat ;
+: ." [char] " word count type ;
--
cgit v1.2.3