commit c7d7ae29540cc0db3c92e246d5f34fe9f0fe9eff
from: Benjamin Stürz <benni@stuerz.xyz>
date: Mon Apr 29 18:34:23 2024 UTC

reimplemented NUMBER in native Forth

commit - 305019da86442226c04b49bf66604da174f04eee
commit + c7d7ae29540cc0db3c92e246d5f34fe9f0fe9eff
blob - 780481aeb4b53f4b4757ad58ed97b0df295f7cf4
blob + 77b5b47b823c52ab40b9107d6aa2ff60165c070f
--- rvforth.S
+++ rvforth.S
@@ -96,6 +96,12 @@ defcode \name, \namelen, \label, \prev, \flags
 	.quad (\label - .)
 .endm
 
+.macro GOTONZ, label
+	.quad EQZ
+	.quad ZBRANCH
+	.quad (\label - .)
+.endm
+
 .section .text
 .global DOCOL
 .type DOCOL, @function
@@ -298,51 +304,7 @@ _EMIT:
 _KEY:
 	j getchar
 .size _KEY, . - _KEY
-
-// a0 - str
-// a1 - len
-_NUMBER:
-	mv t0, zero
-	beq a1, zero, 2f
-	li a2, 1
-
-	lbu t1, 0(a0)
-	li t2, '-'
-	bne t1, t2, 1f
-
-	li a2, -1
-	addi a0, a0, 1
-	addi a1, a1, -1
 
-1:
-	lbu t1, 0(a0)
-	
-	li t2, '0'
-	bltu t1, t2, 2f
-	li t2, '9'
-	bgt t1, t2, 2f
-
-	li t2, 10
-	mul t0, t0, t2
-	add t0, t0, t1
-	addi t0, t0, -'0'
-
-	addi a0, a0, 1
-	addi a1, a1, -1
-
-3:
-	bne a1, zero, 1b
-	li a0, -1
-	//mv a1, t0
-	mul a1, t0, a2
-	jr ra
-
-2:	// not a digit
-	mv a0, zero
-	jr ra
-
-.size _NUMBER, . - _NUMBER
-
 _COMMA:
 	la t0, var_HERE
 	ld t1, 0(t0)
@@ -485,7 +447,21 @@ defcode "0=", 2, EQZ, XOR
 	PUSH t0
 	NEXT
 
-defcode "KEY", 3, KEY, EQZ
+// ( x y -- b )
+defword "=", 1, EQ, EQZ
+	.quad SUB
+	.quad EQZ
+	.quad EXIT
+
+// ( x y -- b )
+defcode "<", 1, LT, EQ
+	POP t0
+	POP t1
+	sltu t0, t0, t1
+	PUSH t0
+	NEXT
+
+defcode "KEY", 3, KEY, LT
 	jal _KEY
 	PUSH a0
 	NEXT
@@ -622,14 +598,87 @@ defword "CREATE", 6, CREATE, CMOVE
 
 	.quad EXIT
 
-defcode "NUMBER", 6, NUMBER, CREATE
-	POP a0
-	POP a1
-	jal _NUMBER
-	PUSH a1
-	PUSH a0
-	NEXT
+// ( str len -- err val )
+defword "NUMBER", 6, NUMBER, CREATE
+	.quad OVER	// ( len str len )
+	GOTOZ 1f	// ( str len )
 
+	.quad DUP	// ( str str len )
+	.quad FETCHBYTE	// ( ch str len )
+	.quad LIT, '-'	// ( '-' ch str len )
+	.quad EQ	// ( eql str len )
+	GOTOZ 2f	// ( str len )
+	
+	.quad LIT, -1	// ( -1 str len )
+	.quad TOR	// ( str len -- -1 )
+	.quad INC	// ( str+1 len -- -1 )
+	.quad SWAP	// ( len str+1 -- -1 )
+	.quad DEC	// ( len-1 str+1 -- -1 )
+	.quad SWAP	// ( str+1 len -- -1 )
+	.quad OVER	// ( len str+1 len -- -1 )
+	.quad EQZ	// ( !len str+1 len -- -1 )
+	GOTOZ 3f	// ( str+1 len -- -1 )
+	
+	.quad RDROP	// ( str len )
+	GOTO 1f		// noreturn
+
+2:
+	.quad LIT, 1	// ( 1 str len )
+	.quad TOR	// ( str len -- 1 )
+
+3:
+	.quad LIT, 0	// ( 0 str len -- neg )
+	.quad TOR	// ( str len -- 0 neg )
+
+4:	// ( str len -- 0 neg )
+	.quad DUP	// ( str str len -- val neg )
+	.quad FETCHBYTE	// ( ch str len -- val neg )
+	.quad LIT, '0'	// ( '0' ch str len -- val neg )
+	.quad OVER	// ( ch '0' ch str len -- val neg )
+	.quad LT	// ( lt ch str len -- val neg )
+	GOTONZ 5f	// ( ch str len -- val neg )
+
+	// ( ch str len -- val neg )
+	.quad DUP	// ( ch ch str len -- val neg )
+	.quad LIT, '9'	// ( '9' ch ch str len -- val neg )
+	.quad LT	// ( lt ch str len -- val neg )
+	GOTONZ 5f	// ( ch str len -- val neg )
+
+	.quad LIT, '0'	// ( '0' ch str len -- val neg )
+	.quad SUB	// ( dig str len -- val neg )
+	.quad FROMR	// ( val dig str len -- neg )
+	.quad LIT, 10	// ( 10 val dig str len -- neg )
+	.quad MUL	// ( val dig str len -- neg )
+	.quad ADD	// ( val str len -- neg )
+	.quad TOR	// ( str len -- val neg )
+
+	.quad INC	// ( str+1 len -- val neg )
+	.quad SWAP	// ( len str+1 -- val neg )
+	.quad DEC	// ( len-1 str+1 -- val neg )
+	.quad SWAP	// ( str+1 len-1 -- val neg )
+	.quad OVER	// ( len-1 str+1 len-1 -- val neg )
+	GOTONZ 4b	// ( str+1 len-1 -- val neg )
+
+	.quad TDROP	// ( -- val neg )
+	.quad FROMR	// ( val -- neg )
+	.quad FROMR	// ( neg val )
+	.quad MUL	// ( val )
+	.quad LIT, -1	// ( -1 val )
+	.quad EXIT
+
+5:	// invalid char	   ( ch str len -- val neg )
+	.quad DROP	// ( str len -- val neg )
+	.quad RDROP	// ( str len -- neg )
+	.quad RDROP	// ( str len )
+	GOTO 1f		// noreturn
+
+1:	// empty string	( str len )
+	.quad TDROP	// ( )
+	.quad LIT, 0	// ( 0 )
+	.quad DUP	// ( 0 0 )
+	.quad EXIT	// noreturn
+	
+
 defcode "ERROR", 5, ERROR, NUMBER
 	la a0, .Lerr
 	jal puts