GH-91 Fix strchr, add strrchr, rename dropn to ndrop

following ForthHub/discussion#186.
SirWumpus · Dec 19, 2024 · 5c43cad · 5c43cad
1 parent 70182aa
commit 5c43cad
Show file tree

Hide file tree

Showing 4 changed files with 58 additions and 25 deletions.
diff --git a/doc/standard.md b/doc/standard.md
@@ -1287,7 +1287,7 @@ System clock time in seconds from the epoch.
 Empty the data stack.
 
 - - -
-#### dropn
+#### ndrop
 ( i*x n*x n -- i*x )  
 Drop the top `n` data stack elements.
 

diff --git a/src/post4.c b/src/post4.c
@@ -2592,7 +2592,8 @@ p4EvalString(P4_Ctx *ctx, const char *str, size_t len)
 	input->length = len;
 	input->offset = 0;
 	input->blk = 0;
-	input->path = "data:";
+	/* RFC 2397 "data:," equals "data:text/plain;charset=US-ASCII," */
+	input->path = "data:,";
 	rc = p4Repl(ctx, P4_THROW_OK);
 	P4_INPUT_POP(ctx->input);
 	return rc;

diff --git a/src/post4.p4 b/src/post4.p4
@@ -334,10 +334,10 @@ END-STRUCTURE
 : R@ R> R> DUP >R SWAP >R ; $1101 _pp!
 
 \ (S: xn ... x1 n -- )
-: dropn CELLS dsp@ SWAP - CELL- dsp! ; $10 _pp!
+: ndrop CELLS dsp@ SWAP - CELL- dsp! ; $10 _pp!
 
 \ ( i*x -- )
-: dropall DEPTH dropn ;
+: dropall DEPTH ndrop ;
 
 \ (S: -- )
 : DECIMAL #10 BASE ! ;
@@ -488,22 +488,18 @@ MAX-U MAX-N 2CONSTANT MAX-D $02 _pp!
 
 \ (S: nu1 nu2 -- flag )
 : = - 0= ; $21 _pp!
-
-\ (S: nu1 nu2 -- flag )
 : <> = 0= ; $21 _pp!
 
 \ (S: n1 n2 -- flag )
 : > SWAP < ; $21 _pp!
-
-\ (S: n1 n2 -- flag )
-: U> SWAP U< ; $21 _pp!
-
-\ (S: n1 n2 -- flag )
 : <= > 0= ; $21 _pp!
-
-\ (S: n1 n2 -- flag )
 : >= < 0= ; $21 _pp!
 
+\ (S: u1 u2 -- flag )
+: U> SWAP U< ; $21 _pp!
+: U<= U> 0= ; $21 _pp!
+: U>= U< 0= ; $21 _pp!
+
 \ ... WITHIN ...
 \
 \ (S: nu1 nu2 nu3 -- flag )
@@ -915,6 +911,8 @@ MAX-U MAX-N 2CONSTANT MAX-D $02 _pp!
 
 \ (S: caddr -- caddr' x )
 : C@+ DUP CHAR+ SWAP C@ ; $12 _pp!
+: C@- DUP CHAR- SWAP C@ ; $12 _pp!
+: C-@ CHAR- DUP C@ ; $12 _pp!
 
 \ (S: x addr -- addr' )
 : !+ DUP CELL+ -rot ! ; $21 _pp!
@@ -1115,16 +1113,30 @@ MAX-U MAX-N 2CONSTANT MAX-D $02 _pp!
 : isalpha toupper 'A' [ 'Z' 1+ ] LITERAL WITHIN ; $11 _pp!
 : isalnum DUP isalpha isdigit OR ; $11 _pp!
 
-\ (S: caddr u delim -- caddr | 0 )
+\ (S: caddr u delim -- caddr' u' )
+\ Find first occurence of delim.
 : strchr
-	>R bounds						\ S: c" c	R: d
-	BEGIN
-		2DUP U> DUP C@ R@ <> AND	\ S: c" c	R: d
-	WHILE							\ S: c" c	R: d
-		1 CHARS +					\ S: c" c'	R: d
-	REPEAT
-	rdrop							\ S: c" c
-	TUCK = IF DUP - THEN			\ S: c | 0
+	>R CHARS bounds
+	BEGIN 2DUP U> WHILE C@+ R@ = UNTIL
+		\ Found.  Return trailing string.
+		CHAR- TUCK -
+	ELSE
+		\ Nothing found.
+		drop 0
+	THEN rdrop
+; $31 _pp!
+
+\ (S: caddr u delim -- caddr' u' )
+\ Find last occurence of delim.
+: strrchr
+	>R STOW CHARS OVER +
+	BEGIN 2DUP U<= WHILE C-@ R@ = UNTIL
+		\ Found.  Return leading string.
+		CHAR+ SWAP -
+	ELSE
+		\ Nothing found.
+		2DROP 0
+	THEN rdrop
 ; $31 _pp!
 
 \ ( caddr u -- )
@@ -1489,6 +1501,9 @@ VARIABLE _pic_off
 \ Copy and NUL terminate string.
 : strncpy 2DUP CHARS + >R MOVE 0 R> C! ;
 
+\ (S: sd.0 -- sd.1 )
+: strndup DUP 1+ ALLOCATE THROW SWAP 2DUP 2>R strncpy 2R> ; $22 _pp!
+
 \ Maximum for octet addressable units.
 MAX-CHAR CONSTANT /COUNTED-STRING
 
@@ -2012,9 +2027,6 @@ VARIABLE SCR
 	!												\ S: --
 ; $30 _pp!
 
-\ (S: sd.0 -- sd.1 )
-: strndup DUP 1+ ALLOCATE THROW SWAP 2DUP 2>R strncpy 2R> ; $22 _pp!
-
 \ (S: -- sd.path )
 file-path source-base-path
 

diff --git a/test/string.p4 b/test/string.p4
@@ -87,6 +87,26 @@ T{ tw_str_2 tw_str_3 COMPARE ->  1 }T
 T{ tw_str_3 tw_str_2 COMPARE -> -1 }T
 test_group_end
 
+.( strchr strrchr ) test_group
+: tw_empty S" " ;
+: tw_no_delim S" foobar" ;
+: tw_leading_delim S" /foo/bar" ;
+: tw_middle_delim S" foo/bar" ;
+: tw_trailing_delim S" foo/bar/" ;
+
+t{ tw_empty '/' strchr tw_empty COMPARE -> 0 }t
+t{ tw_no_delim '/' strchr tw_empty COMPARE -> 0 }t
+t{ tw_leading_delim '/' strchr tw_leading_delim COMPARE -> 0 }t
+t{ tw_middle_delim '/' strchr S" /bar" COMPARE -> 0 }t
+t{ tw_trailing_delim '/' strchr S" /bar/" COMPARE -> 0 }t
+
+t{ tw_empty '/' strrchr tw_empty COMPARE -> 0 }t
+t{ tw_no_delim '/' strrchr tw_empty COMPARE -> 0 }t
+t{ tw_leading_delim '/' strrchr S" /foo/" COMPARE -> 0 }t
+t{ tw_middle_delim '/' strrchr S" foo/" COMPARE -> 0 }t
+t{ tw_trailing_delim '/' strrchr tw_trailing_delim COMPARE -> 0 }t
+test_group_end
+
 .( starts-with ) test_group
 T{ s" " s" " starts-with -> TRUE }T
 T{ s" " s" foo" starts-with -> FALSE }T