mirror of
https://github.com/remko/waforth
synced 2025-01-13 08:01:32 +01:00
<#, #>, #, #S, SIGN, HOLD
This commit is contained in:
Remko Tronçon
parent
ba5bff8a99
commit
ed469cbef4
3 changed files with 155 additions and 68 deletions
|
|
@ -818,57 +818,57 @@ TESTING <# # #S #> HOLD SIGN BASE >NUMBER HEX DECIMAL
|
|||
R> DROP 2DROP <FALSE> \ LENGTHS MISMATCH
|
||||
THEN ;
|
||||
|
||||
\ TODO : GP1 <# 41 HOLD 42 HOLD 0 0 #> S" BA" S= ;
|
||||
\ TODO T{ GP1 -> <TRUE> }T
|
||||
\ TODO
|
||||
\ TODO : GP2 <# -1 SIGN 0 SIGN -1 SIGN 0 0 #> S" --" S= ;
|
||||
\ TODO T{ GP2 -> <TRUE> }T
|
||||
\ TODO
|
||||
\ TODO : GP3 <# 1 0 # # #> S" 01" S= ;
|
||||
\ TODO T{ GP3 -> <TRUE> }T
|
||||
\ TODO
|
||||
\ TODO : GP4 <# 1 0 #S #> S" 1" S= ;
|
||||
\ TODO T{ GP4 -> <TRUE> }T
|
||||
: GP1 <# 41 HOLD 42 HOLD 0 0 #> S" BA" S= ;
|
||||
T{ GP1 -> <TRUE> }T
|
||||
|
||||
: GP2 <# -1 SIGN 0 SIGN -1 SIGN 0 0 #> S" --" S= ;
|
||||
T{ GP2 -> <TRUE> }T
|
||||
|
||||
: GP3 <# 1 0 # # #> S" 01" S= ;
|
||||
T{ GP3 -> <TRUE> }T
|
||||
|
||||
: GP4 <# 1 0 #S #> S" 1" S= ;
|
||||
T{ GP4 -> <TRUE> }T
|
||||
|
||||
24 CONSTANT MAX-BASE \ BASE 2 .. 36
|
||||
: COUNT-BITS
|
||||
0 0 INVERT BEGIN DUP WHILE >R 1+ R> 2* REPEAT DROP ;
|
||||
COUNT-BITS 2* CONSTANT #BITS-UD \ NUMBER OF BITS IN UD
|
||||
|
||||
\ TODO : GP5
|
||||
\ TODO BASE @ <TRUE>
|
||||
\ TODO MAX-BASE 1+ 2 DO \ FOR EACH POSSIBLE BASE
|
||||
\ TODO I BASE ! \ TBD: ASSUMES BASE WORKS
|
||||
\ TODO I 0 <# #S #> S" 10" S= AND
|
||||
\ TODO LOOP
|
||||
\ TODO SWAP BASE ! ;
|
||||
\ TODO T{ GP5 -> <TRUE> }T
|
||||
\ TODO
|
||||
\ TODO : GP6
|
||||
\ TODO BASE @ >R 2 BASE !
|
||||
\ TODO MAX-UINT MAX-UINT <# #S #> \ MAXIMUM UD TO BINARY
|
||||
\ TODO R> BASE ! \ S: C-ADDR U
|
||||
\ TODO DUP #BITS-UD = SWAP
|
||||
\ TODO 0 DO \ S: C-ADDR FLAG
|
||||
\ TODO OVER C@ [CHAR] 1 = AND \ ALL ONES
|
||||
\ TODO >R CHAR+ R>
|
||||
\ TODO LOOP SWAP DROP ;
|
||||
\ TODO T{ GP6 -> <TRUE> }T
|
||||
\ TODO
|
||||
\ TODO : GP7
|
||||
\ TODO BASE @ >R MAX-BASE BASE !
|
||||
\ TODO <TRUE>
|
||||
\ TODO A 0 DO
|
||||
\ TODO I 0 <# #S #>
|
||||
\ TODO 1 = SWAP C@ I 30 + = AND AND
|
||||
\ TODO LOOP
|
||||
\ TODO MAX-BASE A DO
|
||||
\ TODO I 0 <# #S #>
|
||||
\ TODO 1 = SWAP C@ 41 I A - + = AND AND
|
||||
\ TODO LOOP
|
||||
\ TODO R> BASE ! ;
|
||||
\ TODO
|
||||
\ TODO T{ GP7 -> <TRUE> }T
|
||||
: GP5
|
||||
BASE @ <TRUE>
|
||||
MAX-BASE 1+ 2 DO \ FOR EACH POSSIBLE BASE
|
||||
I BASE ! \ TBD: ASSUMES BASE WORKS
|
||||
I 0 <# #S #> S" 10" S= AND
|
||||
LOOP
|
||||
SWAP BASE ! ;
|
||||
T{ GP5 -> <TRUE> }T
|
||||
|
||||
: GP6
|
||||
BASE @ >R 2 BASE !
|
||||
MAX-UINT MAX-UINT <# #S #> \ MAXIMUM UD TO BINARY
|
||||
R> BASE ! \ S: C-ADDR U
|
||||
DUP #BITS-UD = SWAP
|
||||
0 DO \ S: C-ADDR FLAG
|
||||
OVER C@ [CHAR] 1 = AND \ ALL ONES
|
||||
>R CHAR+ R>
|
||||
LOOP SWAP DROP ;
|
||||
T{ GP6 -> <TRUE> }T
|
||||
|
||||
: GP7
|
||||
BASE @ >R MAX-BASE BASE !
|
||||
<TRUE>
|
||||
A 0 DO
|
||||
I 0 <# #S #>
|
||||
1 = SWAP C@ I 30 + = AND AND
|
||||
LOOP
|
||||
MAX-BASE A DO
|
||||
I 0 <# #S #>
|
||||
1 = SWAP C@ 41 I A - + = AND AND
|
||||
LOOP
|
||||
R> BASE ! ;
|
||||
|
||||
T{ GP7 -> <TRUE> }T
|
||||
|
||||
\ >NUMBER TESTS
|
||||
CREATE GN-BUF 0 C,
|
||||
|
|
@ -893,17 +893,17 @@ T{ 0 0 GN' G' 10 >NUMBER-BASED -> 0 0 GN-STRING }T
|
|||
T{ 0 0 GN' G' MAX-BASE >NUMBER-BASED -> 10 0 GN-CONSUMED }T
|
||||
T{ 0 0 GN' Z' MAX-BASE >NUMBER-BASED -> 23 0 GN-CONSUMED }T
|
||||
|
||||
\ TODO : GN1 \ ( UD BASE -- UD' LEN ) UD SHOULD EQUAL UD' AND LEN SHOULD BE ZERO.
|
||||
\ TODO BASE @ >R BASE !
|
||||
\ TODO <# #S #>
|
||||
\ TODO 0 0 2SWAP >NUMBER SWAP DROP \ RETURN LENGTH ONLY
|
||||
\ TODO R> BASE ! ;
|
||||
\ TODO T{ 0 0 2 GN1 -> 0 0 0 }T
|
||||
\ TODO T{ MAX-UINT 0 2 GN1 -> MAX-UINT 0 0 }T
|
||||
\ TODO T{ MAX-UINT DUP 2 GN1 -> MAX-UINT DUP 0 }T
|
||||
\ TODO T{ 0 0 MAX-BASE GN1 -> 0 0 0 }T
|
||||
\ TODO T{ MAX-UINT 0 MAX-BASE GN1 -> MAX-UINT 0 0 }T
|
||||
\ TODO T{ MAX-UINT DUP MAX-BASE GN1 -> MAX-UINT DUP 0 }T
|
||||
: GN1 \ ( UD BASE -- UD' LEN ) UD SHOULD EQUAL UD' AND LEN SHOULD BE ZERO.
|
||||
BASE @ >R BASE !
|
||||
<# #S #>
|
||||
0 0 2SWAP >NUMBER SWAP DROP \ RETURN LENGTH ONLY
|
||||
R> BASE ! ;
|
||||
T{ 0 0 2 GN1 -> 0 0 0 }T
|
||||
T{ MAX-UINT 0 2 GN1 -> MAX-UINT 0 0 }T
|
||||
T{ MAX-UINT DUP 2 GN1 -> MAX-UINT DUP 0 }T
|
||||
T{ 0 0 MAX-BASE GN1 -> 0 0 0 }T
|
||||
T{ MAX-UINT 0 MAX-BASE GN1 -> MAX-UINT 0 0 }T
|
||||
T{ MAX-UINT DUP MAX-BASE GN1 -> MAX-UINT DUP 0 }T
|
||||
|
||||
: GN2 \ ( -- 16 10 )
|
||||
BASE @ >R HEX BASE @ DECIMAL BASE @ R> BASE ! ;
|
||||
|
|
|
|||
|
|
@ -85,6 +85,7 @@
|
|||
;; RETURN_STACK_BASE := 0x2000
|
||||
;; STACK_BASE := 0x10000
|
||||
;; STRINGS_BASE := 0x20000
|
||||
;; PICTURED_OUTPUT_BASE := 0x21000 (filled backward)
|
||||
;; DICTIONARY_BASE := 0x21000
|
||||
(memory (export "memory") 1600 (; = MEMORY_SIZE_PAGES ;))
|
||||
|
||||
|
|
@ -214,16 +215,49 @@
|
|||
(data (i32.const 0x21000 (; = DICTIONARY_BASE ;)) "\00\00\00\00\01!\00\00\10\00\00\00")
|
||||
(elem (i32.const 0x10) $!)
|
||||
|
||||
(func $# (param $tos i32) (result i32)
|
||||
(call $fail (local.get $tos) (i32.const 0x20084))) ;; not implemented
|
||||
(func $# (param $tos i32) (result i32)
|
||||
(local $v i64)
|
||||
(local $base i64)
|
||||
(local $bbtos i32)
|
||||
(local $m i64)
|
||||
(local $npo i32)
|
||||
(local.set $base (i64.extend_i32_u (i32.load (i32.const 0x100 (; = BASE_BASE ;)))))
|
||||
(local.set $v (i64.load (local.tee $bbtos (i32.sub (local.get $tos) (i32.const 8)))))
|
||||
(local.set $m (i64.rem_u (local.get $v) (local.get $base)))
|
||||
(local.set $v (i64.div_u (local.get $v) (local.get $base)))
|
||||
(i32.store8 (local.tee $npo (i32.sub (global.get $po) (i32.const 1)))
|
||||
(call $numberToChar (i32.wrap_i64 (local.get $m))))
|
||||
(i64.store (local.get $bbtos) (local.get $v))
|
||||
(global.set $po (local.get $npo))
|
||||
(local.get $tos))
|
||||
(data (i32.const 135180) "\00\10\02\00\01#\00\00\11\00\00\00")
|
||||
(elem (i32.const 0x11) $#)
|
||||
|
||||
(func $#> (param $tos i32) (result i32) (call $fail (local.get $tos) (i32.const 0x20084))) ;; not implemented
|
||||
(func $#> (param $tos i32) (result i32)
|
||||
(i32.store (i32.sub (local.get $tos) (i32.const 8)) (global.get $po))
|
||||
(i32.store (i32.sub (local.get $tos) (i32.const 4)) (i32.sub (i32.const 0x21000 (; = PICTURED_OUTPUT_BASE ;)) (global.get $po)))
|
||||
(local.get $tos))
|
||||
(data (i32.const 135192) "\0c\10\02\00\02#>\00\12\00\00\00")
|
||||
(elem (i32.const 0x12) $#>)
|
||||
|
||||
(func $#S (param $tos i32) (result i32) (call $fail (local.get $tos) (i32.const 0x20084))) ;; not implemented
|
||||
(func $#S (param $tos i32) (result i32)
|
||||
(local $v i64)
|
||||
(local $base i64)
|
||||
(local $bbtos i32)
|
||||
(local $m i64)
|
||||
(local $po i32)
|
||||
(local.set $base (i64.extend_i32_u (i32.load (i32.const 0x100 (; = BASE_BASE ;)))))
|
||||
(local.set $v (i64.load (local.tee $bbtos (i32.sub (local.get $tos) (i32.const 8)))))
|
||||
(local.set $po (global.get $po))
|
||||
(loop $loop
|
||||
(local.set $m (i64.rem_u (local.get $v) (local.get $base)))
|
||||
(local.set $v (i64.div_u (local.get $v) (local.get $base)))
|
||||
(i32.store8 (local.tee $po (i32.sub (local.get $po) (i32.const 1)))
|
||||
(call $numberToChar (i32.wrap_i64 (local.get $m))))
|
||||
(br_if $loop (i64.ne (local.get $v) (i64.const 0))))
|
||||
(i64.store (local.get $bbtos) (local.get $v))
|
||||
(global.set $po (local.get $po))
|
||||
(local.get $tos))
|
||||
(data (i32.const 135204) "\18\10\02\00\02#S\00\13\00\00\00")
|
||||
(elem (i32.const 0x13) $#S)
|
||||
|
||||
|
|
@ -549,7 +583,8 @@
|
|||
(elem (i32.const 0x2f) $<)
|
||||
|
||||
(func $<# (param $tos i32) (result i32)
|
||||
(call $fail (local.get $tos) (i32.const 0x20084))) ;; not implemented
|
||||
(global.set $po (i32.const 0x21000 (; = PICTURED_OUTPUT_BASE ;)))
|
||||
(local.get $tos))
|
||||
(data (i32.const 135580) "\90\11\02\00\02<#\000\00\00\00")
|
||||
(elem (i32.const 0x30) $<#)
|
||||
|
||||
|
|
@ -942,6 +977,7 @@
|
|||
(data (i32.const 136164) "\d4\13\02\00" "\2b" (; HIDDEN ;) "UNUSED1____" "X\00\00\00")
|
||||
(elem (i32.const 0x58) $UNUSED1)
|
||||
|
||||
;; 6.1.1345
|
||||
(func $ENVIRONMENT? (param $tos i32) (result i32)
|
||||
(local $addr i32)
|
||||
(local $len i32)
|
||||
|
|
@ -1111,7 +1147,13 @@
|
|||
(elem (i32.const 0x5f) $HERE)
|
||||
|
||||
(func $HOLD (param $tos i32) (result i32)
|
||||
(call $fail (local.get $tos) (i32.const 0x20084))) ;; not implemented
|
||||
(local $btos i32)
|
||||
(local $npo i32)
|
||||
(i32.store8
|
||||
(local.tee $npo (i32.sub (global.get $po) (i32.const 1)))
|
||||
(i32.load (local.tee $btos (i32.sub (local.get $tos) (i32.const 4)))))
|
||||
(global.set $po (local.get $npo))
|
||||
(local.get $btos))
|
||||
(data (i32.const 136300) "\5c\14\02\00\04HOLD\00\00\00`\00\00\00")
|
||||
(elem (i32.const 0x60) $HOLD)
|
||||
|
||||
|
|
@ -1406,7 +1448,13 @@
|
|||
|
||||
;; 6.1.2210
|
||||
(func $SIGN (param $tos i32) (result i32)
|
||||
(call $fail (local.get $tos) (i32.const 0x20084))) ;; not implemented
|
||||
(local $btos i32)
|
||||
(local $npo i32)
|
||||
(if (i32.lt_s (i32.load (local.tee $btos (i32.sub (local.get $tos) (i32.const 4)))) (i32.const 0))
|
||||
(then
|
||||
(i32.store8 (local.tee $npo (i32.sub (global.get $po) (i32.const 1))) (i32.const 0x2D (; '-' ;)))
|
||||
(global.set $po (local.get $npo))))
|
||||
(local.get $btos))
|
||||
(data (i32.const 136716) "\00\16\02\00\04SIGN\00\00\00}\00\00\00")
|
||||
(elem (i32.const 0x7d) $SIGN)
|
||||
|
||||
|
|
@ -1835,11 +1883,7 @@
|
|||
(if (i32.eqz (local.get $v))
|
||||
(then)
|
||||
(else (call $U._ (local.get $v) (local.get $base))))
|
||||
(if (i32.ge_u (local.get $m) (i32.const 10))
|
||||
(then
|
||||
(call $shell_emit (i32.add (local.get $m) (i32.const 0x37))))
|
||||
(else
|
||||
(call $shell_emit (i32.add (local.get $m) (i32.const 0x30))))))
|
||||
(call $shell_emit (call $numberToChar (local.get $m))))
|
||||
|
||||
;; 15.6.1.0220
|
||||
(func $.S (param $tos i32) (result i32)
|
||||
|
|
@ -2058,6 +2102,8 @@
|
|||
(global $here (mut i32) (i32.const 0x218c4))
|
||||
(global $nextTableIndex (mut i32) (i32.const 0xaa (; = NEXT_TABLE_INDEX ;)))
|
||||
|
||||
;; Pictured output pointer
|
||||
(global $po (mut i32) (i32.const -1))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Compiler functions
|
||||
|
|
@ -2688,6 +2734,12 @@
|
|||
(return (local.get $n))))
|
||||
(unreachable))
|
||||
|
||||
(func $numberToChar (param $v i32) (result i32)
|
||||
(if (result i32) (i32.ge_u (local.get $v) (i32.const 10))
|
||||
(then
|
||||
(i32.add (local.get $v) (i32.const 0x37)))
|
||||
(else
|
||||
(i32.add (local.get $v) (i32.const 0x30)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; API Functions
|
||||
|
|
|
|||
|
|
@ -1522,6 +1522,41 @@ function loadTests() {
|
|||
});
|
||||
});
|
||||
|
||||
describe("HOLD", () => {
|
||||
it("should work", () => {
|
||||
run("<# 65 HOLD 66 HOLD 0 0 #> TYPE");
|
||||
expect(output.trim()).to.eql("BA");
|
||||
expect(stackValues()).to.eql([]);
|
||||
});
|
||||
});
|
||||
|
||||
describe("SIGN", () => {
|
||||
it("should support positive", () => {
|
||||
run("<# 65 HOLD 123 SIGN 66 HOLD 0 0 #> TYPE");
|
||||
expect(output.trim()).to.eql("BA");
|
||||
expect(stackValues()).to.eql([]);
|
||||
});
|
||||
|
||||
it("should support negative", () => {
|
||||
run("<# 65 HOLD -123 SIGN 66 HOLD 0 0 #> TYPE");
|
||||
expect(output.trim()).to.eql("B-A");
|
||||
expect(stackValues()).to.eql([]);
|
||||
});
|
||||
});
|
||||
|
||||
describe("#", () => {
|
||||
it("should work", () => {
|
||||
run("<# 123 0 # #> TYPE");
|
||||
expect(output.trim()).to.eql("3");
|
||||
expect(stackValues()).to.eql([]);
|
||||
});
|
||||
});
|
||||
|
||||
it("should work", () => {
|
||||
run("<# 12345 0 # # 46 HOLD #S #> TYPE");
|
||||
expect(output.trim()).to.eql("123.45");
|
||||
});
|
||||
|
||||
describe("system", () => {
|
||||
it("should run sieve", () => {
|
||||
run(sieve);
|
||||
|
|
|
|||
Loading…
Reference in a new issue