From d97a6915a5d605ba76426d3fe502afcf03db04d7 Mon Sep 17 00:00:00 2001
From: Brad Nelson <flagxor@gmail.com>
Date: Tue, 7 Jun 2022 20:32:01 -0700
Subject: [PATCH] Make CRLF handling in accept more robust.

---
 common/base_tests.fs |  9 ++++++++-
 common/boot.fs       | 14 +++++++++-----
 common/testing.fs    |  1 +
 common/vocabulary.fs |  1 +
 4 files changed, 19 insertions(+), 6 deletions(-)

diff --git a/common/base_tests.fs b/common/base_tests.fs
index ce2ab44..a279bbe 100644
--- a/common/base_tests.fs
+++ b/common/base_tests.fs
@@ -103,8 +103,15 @@ e: test-accept
   in: 1234567890xxxxxx
   pad 10 accept
   pad swap type cr
-  out: --> 1234567890
+  out:\ --> 1234567890
+  out:crlf
   out: 1234567890
+  in: foo
+  pad 10 accept
+  pad swap type cr
+  out:\ --> foo
+  out:crlf
+  out: foo
 ;e
 
 e: test-key
diff --git a/common/boot.fs b/common/boot.fs
index 95e9257..56274c4 100644
--- a/common/boot.fs
+++ b/common/boot.fs
@@ -158,12 +158,16 @@ variable hld
 
 ( Input )
 : raw.s   depth 0 max for aft sp@ r@ cells - @ . then next ;
-variable echo -1 echo !   variable arrow -1 arrow !
-: ?echo ( n -- ) echo @ if emit else drop then ;
+variable echo -1 echo !   variable arrow -1 arrow !  variable wascr
+: *emit ( n -- ) dup emit 13 = if cr then ;
+: ?echo ( n -- ) echo @ if *emit else drop then ;
 : ?arrow.   arrow @ if >r >r raw.s r> r> ." --> " then ;
+: *key ( -- n )
+  begin key dup nl = wascr @ 0= and if drop 13 exit then dup until
+  dup 13 = wascr ! ;
 : accept ( a n -- n ) ?arrow. 0 swap begin 2dup < while
-     key
-     dup nl = over 13 = or if ?echo drop nip exit then
+     *key
+     dup 13 = if ?echo drop nip exit then
      dup 8 = over 127 = or if
        drop over if rot 1- rot 1- rot 8 ?echo bl ?echo 8 ?echo then
      else
@@ -172,7 +176,7 @@ variable echo -1 echo !   variable arrow -1 arrow !
      then
    repeat drop nip
    ( Eat rest of the line if buffer too small )
-   begin key dup nl = over 13 = or if ?echo exit else drop then again
+   begin *key dup 13 = if ?echo exit else drop then again
 ;
 200 constant input-limit
 : tib ( -- a ) 'tib @ ;
diff --git a/common/testing.fs b/common/testing.fs
index 7d2d294..6c32d33 100644
--- a/common/testing.fs
+++ b/common/testing.fs
@@ -46,6 +46,7 @@ variable expect-used   variable result-used
 : expected ( -- a n ) expect-buffer expect-used @ ;
 : resulted ( -- a n ) result-buffer result-used @ ;
 : out:cr   nl expect-emit ;
+: out:crlf   13 expect-emit nl expect-emit ;
 : out:\ ( "line" -- ) nl parse expect-type ;
 : out: ( "line" -- ) out:\ out:cr ;
 variable confirm-old-type
diff --git a/common/vocabulary.fs b/common/vocabulary.fs
index 63b7e40..4dbc967 100644
--- a/common/vocabulary.fs
+++ b/common/vocabulary.fs
@@ -53,6 +53,7 @@ variable scope   scope context cell - !
 transfer{
   xt-find& xt-hide xt-transfer
   voc-stack-end last-vocabulary notfound
+  *key *emit wascr
   immediate? input-buffer ?echo ?arrow. arrow
   evaluate-buffer aliteral value-bind
   leaving( )leaving leaving leaving,