├── .vscode └── settings.json ├── .gitignore ├── src ├── app │ ├── test │ │ ├── testbig.fs │ │ ├── testbitcoinbig.fs │ │ ├── testbitcoin.fs │ │ ├── testrecorder.fs │ │ └── ttester.fs │ ├── functions.fs │ ├── lib │ │ ├── altstack.fs │ │ └── big.4th │ ├── taperecorder.fs │ ├── sqrt.fs │ ├── bitcoin-common.fs │ ├── bitcoin-big.fs │ └── bitcoin.fs └── js │ ├── wallet.json │ └── broadcaster.js ├── hackathon ├── js │ ├── wallet.json │ └── broadcaster.js └── app │ ├── hack.hll │ ├── functions.fs │ ├── altstack.fs │ ├── taperecorder.fs │ ├── hack.hll.script │ ├── testbitcoin.fs │ ├── sqrt.fs │ ├── hack.fs │ ├── testrecorder.fs │ ├── bitcoin.fs │ └── ttester.fs ├── package.json ├── LICENSE └── README.md /.vscode/settings.json: -------------------------------------------------------------------------------- 1 | { 2 | "git.ignoreLimitWarning": true 3 | } -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | node_modules 2 | tape.txt 3 | wallet.* 4 | wallet*.json 5 | !wallet.json 6 | -------------------------------------------------------------------------------- /src/app/test/testbig.fs: -------------------------------------------------------------------------------- 1 | \ Tests for bignum library 2 | require ../lib/big.4th 3 | require ttester.fs 4 | 5 | T{ big 1 big 2 big+ big 3 big= -> true }T 6 | -------------------------------------------------------------------------------- /src/js/wallet.json: -------------------------------------------------------------------------------- 1 | { 2 | "mnemonic": "finish attack near enter have kingdom axis sun night help economy receive", 3 | "wif": "", 4 | "legacyAddress": "mtr9aBa6Q1bH6aKkKWZmPya2v9AjRerj31" 5 | } -------------------------------------------------------------------------------- /hackathon/js/wallet.json: -------------------------------------------------------------------------------- 1 | { 2 | "mnemonic": "finish attack near enter have kingdom axis sun night help economy receive", 3 | "wif": "", 4 | "legacyAddress": "mtr9aBa6Q1bH6aKkKWZmPya2v9AjRerj31" 5 | } -------------------------------------------------------------------------------- /hackathon/app/hack.hll: -------------------------------------------------------------------------------- 1 | ### A Hello app created with BSV Editor 2 | ### To compile, open in BSV Editor However, script output file will need to be edited 3 | ### to make it run in Tape Recorder 4 | cnt = 0x02; 5 | for i in [1 .. 2] 6 | { 7 | cnt = cnt + i; 8 | } 9 | 10 | 11 | 12 | 13 | -------------------------------------------------------------------------------- /src/app/functions.fs: -------------------------------------------------------------------------------- 1 | \ General function library 2 | 3 | : log2 ( +n1 -- n2 ) 4 | \ logarithmus dualis of n1>0, rounded down to the next integer 5 | assert( dup 0> ) 6 | 2/ 0 begin 7 | over 0> while 8 | 1+ swap 2/ swap 9 | repeat 10 | nip 11 | ; 12 | 13 | \ Size of a number in bits, i.e. number of bits it takes to hold a decimal number 14 | : SizeOfNumberInBits log2 ; 15 | 16 | : SizeOfNumberInBytes log2 8 / 1+ ; 17 | -------------------------------------------------------------------------------- /hackathon/app/functions.fs: -------------------------------------------------------------------------------- 1 | \ General function library 2 | 3 | : log2 ( +n1 -- n2 ) 4 | \ logarithmus dualis of n1>0, rounded down to the next integer 5 | assert( dup 0> ) 6 | 2/ 0 begin 7 | over 0> while 8 | 1+ swap 2/ swap 9 | repeat 10 | nip 11 | ; 12 | 13 | \ Size of a number in bits, i.e. number of bits it takes to hold a decimal number 14 | : SizeOfNumberInBits log2 ; 15 | 16 | : SizeOfNumberInBytes log2 8 / 1+ ; 17 | -------------------------------------------------------------------------------- /src/app/lib/altstack.fs: -------------------------------------------------------------------------------- 1 | \ An implementation of an alternative stack for Forth 2 | \ Forth's return stack could not be used as Bitcoin's alt stack 3 | \ This stack is based on the LIFO stack pattern 4 | : altstack ( n -- ) 5 | create here cell+ , cells allot does> ; 6 | 7 | : altpush ( n altstack -- ) 8 | swap over @ ! cell swap +! ; 9 | 10 | : altpop ( altstack -- x ) 11 | cell negate over +! dup @ swap over >= 12 | abort" [altstack underflow] " @ ; 13 | 14 | : altclear ( altstack -- ) dup cell+ swap ! ; 15 | : altbounds ( altstack -- addr1 addr2 ) dup @ swap cell+ ; -------------------------------------------------------------------------------- /hackathon/app/altstack.fs: -------------------------------------------------------------------------------- 1 | \ An implementation of an alternative stack for Forth 2 | \ Forth's return stack could not be used as Bitcoin's alt stack 3 | \ This stack is based on the LIFO stack pattern 4 | : altstack ( n -- ) 5 | create here cell+ , cells allot does> ; 6 | 7 | : altpush ( n altstack -- ) 8 | swap over @ ! cell swap +! ; 9 | 10 | : altpop ( altstack -- x ) 11 | cell negate over +! dup @ swap over >= 12 | abort" [altstack underflow] " @ ; 13 | 14 | : altclear ( altstack -- ) dup cell+ swap ! ; 15 | : altbounds ( altstack -- addr1 addr2 ) dup @ swap cell+ ; -------------------------------------------------------------------------------- /src/app/taperecorder.fs: -------------------------------------------------------------------------------- 1 | \ use 'include taperecorder.fs' to load this file into your forth environment 2 | \ reload is a command to reset your environment 3 | : reload clearstack s" taperecorder.fs" included ; 4 | 5 | \ helper words 6 | : 3drop drop 2drop ; 7 | 8 | \ output formatting words 9 | : ## s>d <# # # #> ; 10 | : to-hex hex ## decimal ; 11 | 12 | \ File handling words 13 | 0 Value fd 14 | \ writes to file if a file is open 15 | : console-or-file fd dup 0> if write-file throw else 3drop then ; 16 | : recorder-on-file w/o create-file throw to fd ; 17 | : recorder-on s" tape.txt" recorder-on-file ; 18 | : ron recorder-on ; 19 | : recorder-off fd close-file throw 0 to fd ; 20 | : roff recorder-off ; 21 | : write to-hex console-or-file ; 22 | 23 | \ include bitcoin opcodes here ... 24 | include bitcoin.fs 25 | -------------------------------------------------------------------------------- /hackathon/app/taperecorder.fs: -------------------------------------------------------------------------------- 1 | \ use 'include taperecorder.fs' to load this file into your forth environment 2 | \ reload is a command to reset your environment 3 | : reload clearstack s" taperecorder.fs" included ; 4 | 5 | \ helper words 6 | : 3drop drop 2drop ; 7 | 8 | \ output formatting words 9 | : ## s>d <# # # #> ; 10 | : to-hex hex ## decimal ; 11 | 12 | \ File handling words 13 | 0 Value fd 14 | \ writes to file if a file is open 15 | : console-or-file fd dup 0> if write-file throw else 3drop then ; 16 | : recorder-on-file w/o create-file throw to fd ; 17 | : recorder-on s" tape.txt" recorder-on-file ; 18 | : ron recorder-on ; 19 | : recorder-off fd close-file throw 0 to fd ; 20 | : roff recorder-off ; 21 | : write to-hex console-or-file ; 22 | 23 | \ include bitcoin opcodes here ... 24 | include bitcoin.fs 25 | -------------------------------------------------------------------------------- /package.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "tape-recorder", 3 | "version": "1.0.0", 4 | "description": "It records your application and puts it on the blockchain", 5 | "main": "index.js", 6 | "scripts": { 7 | "test": "echo \"Error: no test specified\" && exit 1" 8 | }, 9 | "repository": { 10 | "type": "git", 11 | "url": "git+https://github.com/dfoderick/tape-recorder.git" 12 | }, 13 | "keywords": [ 14 | "tape", 15 | "recorder", 16 | "bitcoin", 17 | "wang", 18 | "b" 19 | ], 20 | "author": "David Foderick", 21 | "license": "ISC", 22 | "bugs": { 23 | "url": "https://github.com/dfoderick/tape-recorder/issues" 24 | }, 25 | "homepage": "https://github.com/dfoderick/tape-recorder#readme", 26 | "dependencies": { 27 | "axios": "^0.19.0", 28 | "bsv": "^0.29.2" 29 | } 30 | } 31 | -------------------------------------------------------------------------------- /hackathon/app/hack.hll.script: -------------------------------------------------------------------------------- 1 | ### Autogenerated Hello script. Created @ Sat Aug 17 20:11:41 2019 2 | 3 | ### 4 | ### cnt = 0x02; 5 | ### 6 | L1 0x02 7 | OP_TOALTSTACK 8 | 9 | ### 10 | ### for i in [1 .. 2] 11 | ### 12 | L1 0x01 13 | OP_TOALTSTACK 14 | 15 | ### 16 | ### 17 | ### cnt = cnt + i; 18 | ### 19 | OP_FROMALTSTACK 20 | OP_FROMALTSTACK 21 | OP_DUP 22 | OP_TOALTSTACK 23 | OP_SWAP 24 | OP_TOALTSTACK 25 | OP_FROMALTSTACK 26 | OP_DUP 27 | OP_TOALTSTACK 28 | OP_ADD 29 | OP_FROMALTSTACK 30 | OP_FROMALTSTACK 31 | OP_DROP 32 | L1 0x01 33 | OP_ROLL 34 | OP_TOALTSTACK 35 | OP_TOALTSTACK 36 | L1 0x02 37 | OP_FROMALTSTACK 38 | OP_DROP 39 | OP_TOALTSTACK 40 | 41 | ### 42 | ### 43 | ### cnt = cnt + i; 44 | ### 45 | OP_FROMALTSTACK 46 | OP_FROMALTSTACK 47 | OP_DUP 48 | OP_TOALTSTACK 49 | OP_SWAP 50 | OP_TOALTSTACK 51 | OP_FROMALTSTACK 52 | OP_DUP 53 | OP_TOALTSTACK 54 | OP_ADD 55 | OP_FROMALTSTACK 56 | OP_FROMALTSTACK 57 | OP_DROP 58 | L1 0x01 59 | OP_ROLL 60 | OP_TOALTSTACK 61 | OP_TOALTSTACK 62 | -------------------------------------------------------------------------------- /src/app/test/testbitcoinbig.fs: -------------------------------------------------------------------------------- 1 | \ bitcoin bignum tests 2 | require ttester.fs 3 | include ../bitcoin-big.fs 4 | cr clearstack 5 | T{ OP_1 OP_1 OP_ADD OP_2 OP_EQUAL -> true }T 6 | T{ big 1 OP_IFDUP depth 2 = 2nip -> true }T 7 | T{ big 0 OP_IFDUP depth 1 = nip -> true }T 8 | T{ big 1 big 5 big 2 OP_WITHIN -> true }T 9 | T{ big 1 big 5 big 9 OP_WITHIN -> false }T 10 | T{ big 1 OP_NOT big 0 big= -> true }T 11 | T{ big 9 OP_NOT big 0 big= -> true }T 12 | T{ big 0 OP_NOT big 1 big= -> true }T 13 | T{ big 0 OP_0NOTEQUAL big 0 big= -> true }T 14 | T{ big 1 OP_0NOTEQUAL big 1 big= -> true }T 15 | T{ big 9 OP_0NOTEQUAL big 1 big= -> true }T 16 | 17 | T{ OP_1 big 1 big= -> true }T 18 | T{ OP_2 big 2 big= -> true }T 19 | T{ OP_3 big 3 big= -> true }T 20 | T{ OP_4 big 4 big= -> true }T 21 | T{ OP_5 big 5 big= -> true }T 22 | T{ OP_6 big 6 big= -> true }T 23 | T{ OP_7 big 7 big= -> true }T 24 | T{ OP_8 big 8 big= -> true }T 25 | T{ OP_9 big 9 big= -> true }T 26 | T{ OP_10 big 10 big= -> true }T 27 | T{ OP_11 big 11 big= -> true }T 28 | T{ OP_12 big 12 big= -> true }T 29 | T{ OP_13 big 13 big= -> true }T 30 | T{ OP_14 big 14 big= -> true }T 31 | T{ OP_15 big 15 big= -> true }T 32 | -------------------------------------------------------------------------------- /hackathon/app/testbitcoin.fs: -------------------------------------------------------------------------------- 1 | \ basic bitcoin tests 2 | require ttester.fs 3 | require bitcoin.fs 4 | cr 5 | T{ OP_1 OP_1 OP_ADD -> 2 }T 6 | T{ 1 OP_IFDUP -> 1 1 }T 7 | T{ 0 OP_IFDUP -> 0 }T 8 | T{ 1 5 2 OP_WITHIN -> true }T 9 | T{ 1 5 9 OP_WITHIN -> false }T 10 | T{ 1 OP_NOT -> false }T 11 | T{ 9 OP_NOT -> false }T 12 | T{ 0 OP_NOT -> 1 }T 13 | T{ 0 OP_0NOTEQUAL -> false }T 14 | T{ 1 OP_0NOTEQUAL -> 1 }T 15 | T{ 9 OP_0NOTEQUAL -> 1 }T 16 | 17 | T{ OP_1 -> 1 }T 18 | T{ OP_2 -> 2 }T 19 | T{ OP_3 -> 3 }T 20 | T{ OP_4 -> 4 }T 21 | T{ OP_5 -> 5 }T 22 | T{ OP_6 -> 6 }T 23 | T{ OP_7 -> 7 }T 24 | T{ OP_8 -> 8 }T 25 | T{ OP_9 -> 9 }T 26 | T{ OP_10 -> 10 }T 27 | T{ OP_11 -> 11 }T 28 | T{ OP_12 -> 12 }T 29 | T{ OP_13 -> 13 }T 30 | T{ OP_14 -> 14 }T 31 | T{ OP_15 -> 15 }T 32 | 33 | \ ttester does not handle strings 34 | T{ s" hello" s" world" OP_CAT s" helloworld" compare -> 0 }T 35 | T{ s" hitape" OP_SIZE rot 2drop -> 6 }T 36 | T{ s" helloworld" 2 bitcoin_left s" he" compare -> 0 }T 37 | T{ s" helloworld" 4 bitcoin_right s" orld" compare -> 0 }T 38 | T{ s" helloworld" 5 OP_SPLIT 2swap 2drop s" hello" compare -> 0 }T 39 | T{ s" helloworld" 5 OP_SPLIT 2drop s" world" compare -> 0 }T 40 | T{ s" helloworld" 1 OP_SPLIT 2swap 2drop s" h" compare -> 0 }T 41 | -------------------------------------------------------------------------------- /src/app/test/testbitcoin.fs: -------------------------------------------------------------------------------- 1 | \ basic bitcoin tests 2 | require ttester.fs 3 | include ../bitcoin.fs 4 | cr 5 | T{ OP_1 OP_1 OP_ADD -> 2 }T 6 | T{ 1 OP_IFDUP -> 1 1 }T 7 | T{ 0 OP_IFDUP -> 0 }T 8 | T{ 1 5 2 OP_WITHIN -> true }T 9 | T{ 1 5 9 OP_WITHIN -> false }T 10 | T{ 1 OP_NOT -> false }T 11 | T{ 9 OP_NOT -> false }T 12 | T{ 0 OP_NOT -> 1 }T 13 | T{ 0 OP_0NOTEQUAL -> false }T 14 | T{ 1 OP_0NOTEQUAL -> 1 }T 15 | T{ 9 OP_0NOTEQUAL -> 1 }T 16 | 17 | T{ OP_1 -> 1 }T 18 | T{ OP_2 -> 2 }T 19 | T{ OP_3 -> 3 }T 20 | T{ OP_4 -> 4 }T 21 | T{ OP_5 -> 5 }T 22 | T{ OP_6 -> 6 }T 23 | T{ OP_7 -> 7 }T 24 | T{ OP_8 -> 8 }T 25 | T{ OP_9 -> 9 }T 26 | T{ OP_10 -> 10 }T 27 | T{ OP_11 -> 11 }T 28 | T{ OP_12 -> 12 }T 29 | T{ OP_13 -> 13 }T 30 | T{ OP_14 -> 14 }T 31 | T{ OP_15 -> 15 }T 32 | 33 | \ ttester does not handle strings 34 | T{ s" hello" s" world" OP_CAT s" helloworld" compare -> 0 }T 35 | T{ s" hitape" OP_SIZE rot 2drop -> 6 }T 36 | T{ s" helloworld" 2 bitcoin_left s" he" compare -> 0 }T 37 | T{ s" helloworld" 4 bitcoin_right s" orld" compare -> 0 }T 38 | T{ s" helloworld" 5 OP_SPLIT 2swap 2drop s" hello" compare -> 0 }T 39 | T{ s" helloworld" 5 OP_SPLIT 2drop s" world" compare -> 0 }T 40 | T{ s" helloworld" 1 OP_SPLIT 2swap 2drop s" h" compare -> 0 }T 41 | -------------------------------------------------------------------------------- /src/app/sqrt.fs: -------------------------------------------------------------------------------- 1 | \ Newton's method to compute square root using Forth to execute to bitcoin script 2 | \ Note that this algorithm does not give the correct result for some integers (i.e. sqrt(3) <> 2) 3 | \ See https://github.com/dfoderick/tape-recorder 4 | include taperecorder.fs 5 | 6 | \ z = (x+1)/2 7 | : guess-start OP_1ADD OP_2DIV ; 8 | 9 | \ z = ( x / z + z) / 2 10 | : guess-next ( x y z -- x y newguess) 11 | OP_DUP ( x y z z) 12 | OP_3 OP_PICK ( x y z z x) 13 | OP_SWAP ( x y z x z) 14 | OP_DIV ( x y z x/z) 15 | OP_ADD ( x y x/z+z) 16 | OP_2DIV ( x y result) 17 | ; 18 | 19 | : sqrt ( n -- y) 20 | OP_DUP OP_DUP 21 | guess-start 22 | \ through each iteration stack looks like [x y z] where z is next guess 23 | begin 24 | \ while z < y 25 | OP_2DUP OP_SWAP OP_LESSTHAN 26 | while 27 | OP_IF 28 | \ y = z 29 | OP_NIP OP_DUP 30 | \ z = ( x / z + z) / 2 31 | guess-next 32 | OP_ENDIF 33 | repeat 34 | \ close the bitcoin loop by consuming the 0 (false) at TOS 35 | OP_IF OP_ENDIF 36 | OP_NIP OP_NIP 37 | ; 38 | 39 | \ 9 sqrt . 3 ok 40 | \ 6 sqrt . 2 ok 41 | \ 144 sqrt . 12 ok 42 | \ 169 sqrt . 13 ok 43 | \ 180 sqrt . 13 ok 44 | \ 1000000 sqrt . 1000 ok 45 | 46 | -------------------------------------------------------------------------------- /hackathon/app/sqrt.fs: -------------------------------------------------------------------------------- 1 | \ Newton's method to compute square root using Forth to execute to bitcoin script 2 | \ Note that this algorithm does not give the correct result for some integers (i.e. sqrt(3) <> 2) 3 | \ See https://github.com/dfoderick/tape-recorder 4 | include taperecorder.fs 5 | 6 | \ z = (x+1)/2 7 | : guess-start OP_1ADD OP_2DIV ; 8 | 9 | \ z = ( x / z + z) / 2 10 | : guess-next ( x y z -- x y newguess) 11 | OP_DUP ( x y z z) 12 | OP_3 OP_PICK ( x y z z x) 13 | OP_SWAP ( x y z x z) 14 | OP_DIV ( x y z x/z) 15 | OP_ADD ( x y x/z+z) 16 | OP_2DIV ( x y result) 17 | ; 18 | 19 | : sqrt ( n -- y) 20 | OP_DUP OP_DUP 21 | guess-start 22 | \ through each iteration stack looks like [x y z] where z is next guess 23 | begin 24 | \ while z < y 25 | OP_2DUP OP_SWAP OP_LESSTHAN 26 | while 27 | OP_IF 28 | \ y = z 29 | OP_NIP OP_DUP 30 | \ z = ( x / z + z) / 2 31 | guess-next 32 | OP_ENDIF 33 | repeat 34 | \ close the bitcoin loop by consuming the 0 (false) at TOS 35 | OP_IF OP_ENDIF 36 | OP_NIP OP_NIP 37 | ; 38 | 39 | \ 9 sqrt . 3 ok 40 | \ 6 sqrt . 2 ok 41 | \ 144 sqrt . 12 ok 42 | \ 169 sqrt . 13 ok 43 | \ 180 sqrt . 13 ok 44 | \ 1000000 sqrt . 1000 ok 45 | 46 | -------------------------------------------------------------------------------- /src/app/bitcoin-common.fs: -------------------------------------------------------------------------------- 1 | \ common words between regular and big number machines 2 | 3 | include lib/altstack.fs 4 | \ defines altstack named alt with only 10 capacity 5 | 100 altstack alt 6 | 7 | : bitcoin_verify 8 | true <> if 9 | assert( false ) 10 | then 11 | ; 12 | 13 | : OP_NOP 0x61 write ; 14 | 15 | \ =============== Stack words ============================ 16 | \ has to consume TOS according to new specification 17 | : OP_RETURN drop 0x6A write ; 18 | : OP_TOALTSTACK alt altpush 0x6B write ; 19 | : OP_FROMALTSTACK alt altpop 0x6C write ; 20 | : OP_DEPTH depth 0x74 write ; 21 | : OP_DROP drop 0x75 write ; 22 | : OP_DUP dup 0x76 write ; 23 | : OP_NIP nip 0x77 write ; 24 | : OP_OVER over 0x78 write ; 25 | : OP_PICK pick 0x79 write ; 26 | : OP_ROLL roll 0x7A write ; 27 | : OP_ROT rot 0x7B write ; 28 | : OP_SWAP swap 0x7C write ; 29 | : OP_TUCK tuck 0x7D write ; 30 | : OP_2DROP 2drop 0x6D write ; 31 | : OP_2DUP 2dup 0x6E write ; 32 | : OP_3DUP dup 2over rot 0x6F write ; 33 | : OP_2OVER 2over 0x70 write ; 34 | : OP_2ROT 2rot 0x71 write ; 35 | : OP_2SWAP 2swap 0x72 write ; 36 | 37 | \ ============= Miscellaneous Words ======================= 38 | : OP_CODESEPARATOR 0xAB write ; 39 | 40 | \ dummy opcodes. These would be used when there is no 1-to-1 correspondence 41 | \ between forth and bitcoin operations. 42 | \ Forth while loop consumes TOS so have to drop on bitcoin side to maintain stack 43 | : OP_WHILE drop ; 44 | -------------------------------------------------------------------------------- /hackathon/app/hack.fs: -------------------------------------------------------------------------------- 1 | \ ### Autogenerated Hello script. Created @ Sat Aug 17 11:04:34 2019 2 | \ Created using BSV Editor 3 | \ Contents were modified (slightly) by hand to make it compatible with Tape Recorder 4 | \ See hack.hll and hack.hll.script for original version 5 | : hello_compiled 6 | \ ### 7 | \ ### cnt = 0x02; 8 | \ ### 9 | 0x02 PUSHDATA 10 | OP_TOALTSTACK 11 | 12 | \ ### 13 | \ ### for i in [1 .. 2] 14 | \ ### 15 | 0x01 PUSHDATA 16 | OP_TOALTSTACK 17 | 18 | \ ### 19 | \ ### 20 | \ ### cnt = cnt + i; 21 | \ ### 22 | OP_FROMALTSTACK 23 | OP_FROMALTSTACK 24 | OP_DUP 25 | OP_TOALTSTACK 26 | OP_SWAP 27 | OP_TOALTSTACK 28 | OP_FROMALTSTACK 29 | OP_DUP 30 | OP_TOALTSTACK 31 | OP_ADD 32 | OP_FROMALTSTACK 33 | OP_FROMALTSTACK 34 | OP_DROP 35 | 0x01 PUSHDATA 36 | OP_ROLL 37 | OP_TOALTSTACK 38 | OP_TOALTSTACK 39 | 0x02 PUSHDATA 40 | OP_FROMALTSTACK 41 | OP_DROP 42 | OP_TOALTSTACK 43 | 44 | \ ### 45 | \ ### 46 | \ ### cnt = cnt + i; 47 | \ ### 48 | OP_FROMALTSTACK 49 | OP_FROMALTSTACK 50 | OP_DUP 51 | OP_TOALTSTACK 52 | OP_SWAP 53 | OP_TOALTSTACK 54 | OP_FROMALTSTACK 55 | OP_DUP 56 | OP_TOALTSTACK 57 | OP_ADD 58 | OP_FROMALTSTACK 59 | OP_FROMALTSTACK 60 | OP_DROP 61 | 0x01 PUSHDATA 62 | OP_ROLL 63 | OP_TOALTSTACK 64 | OP_TOALTSTACK 65 | 66 | \ End of compiled script 67 | \ Added this check results for correctness 68 | \ result and loop index are left on the alt stack so gotta pop them off 69 | OP_FROMALTSTACK 70 | OP_DROP 71 | OP_FROMALTSTACK 72 | \ result of computation is now TOS 73 | ; -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Open BSV License 2 | Copyright (c) 2019 David Foderick 3 | 4 | Permission is hereby granted, free of charge, to any person obtaining a copy 5 | of this software and associated documentation files (the "Software"), to deal 6 | in the Software without restriction, including without limitation the rights 7 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 8 | copies of the Software, and to permit persons to whom the Software is 9 | furnished to do so, subject to the following conditions: 10 | 11 | 1 - The above copyright notice and this permission notice shall be included in 12 | all copies or substantial portions of the Software. 13 | 2 - The Software, and any software that is derived from the Software or parts thereof, 14 | can only be used on the Bitcoin SV blockchains. The Bitcoin SV blockchains are defined, 15 | for purposes of this license, as the Bitcoin blockchain containing block height #556767 16 | with the hash "000000000000000001d956714215d96ffc00e0afda4cd0a96c96f8d802b1662b" and 17 | the test blockchains that are supported by the un-modified Software. 18 | 19 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 20 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 21 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 22 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 23 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 24 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 25 | THE SOFTWARE. -------------------------------------------------------------------------------- /hackathon/app/testrecorder.fs: -------------------------------------------------------------------------------- 1 | \ testing words 2 | require ttester.fs 3 | 4 | \ simple add. 1 + 1 = 2 5 | : testadd recorder-on 1 PUSHDATA 1 PUSHDATA OP_ADD recorder-off ; 6 | : testadd_op recorder-on OP_1 OP_1 OP_ADD recorder-off ; 7 | clearstack T{ testadd -> 2 }T 8 | 9 | \ looping factorial 10 | \ notice I am only recording the necessary calculations for a thread of execution 11 | \ looping outer constructs are not getting recorded for these demos 12 | : fac 1 PUSHDATA swap 1+ 1 ?do i PUSHDATA OP_MUL loop ; 13 | : testfac recorder-on 5 fac recorder-off ; 14 | T{ 5 fac -> 120 }T 15 | clearstack T{ testfac -> 120 }T 16 | 17 | \ looping square root 18 | \ this is native forth implementation 19 | \ This implementation does not leave a clean stack on the bitcoin script side 20 | \ original forth 21 | \ : sqrt-closer ( square guess -- square guess adjustment) 2dup / over - 2 / ; 22 | \ : sqrt ( square -- root ) 1 begin sqrt-closer dup while + repeat drop nip ; 23 | \ : sqrt-closer ( square guess -- square guess adjustment) OP_2DUP OP_DIV OP_OVER OP_SUB OP_2DIV ; 24 | \ : sqrt ( square -- root ) OP_1 begin sqrt-closer OP_DUP while OP_ADD repeat OP_DROP OP_NIP ; 25 | 26 | : xnew ( n xold n xnew ) 27 | \ 2DUP / + 2/ ; 28 | OP_2DUP OP_DIV OP_ADD OP_2DIV ; 29 | 30 | \ This works for 9 and 81 but not 169? 31 | : sqrt ( n root ) 32 | \ DUP 1 > 33 | \ IF DUP 2/ ( n n/2 ) 10 0 DO XNEW LOOP NIP 34 | \ THEN ; 35 | OP_DUP OP_2DIV ( n n/2 ) 10 0 DO xnew LOOP OP_NIP 36 | ; 37 | 38 | : testsqrt recorder-on 9 PUSHDATA sqrt recorder-off ; 39 | clearstack T{ testsqrt -> 3 }T 40 | 41 | \ looping greatest common divisor 42 | : gcd ( a b -- n ) 43 | \ OP_2DUP <= if OP_SWAP ( Y X ) then 44 | begin 45 | OP_TUCK 46 | OP_MOD 47 | dup 48 | 0= until 49 | OP_DROP ; 50 | : testgcd recorder-on 105 PUSHDATA 28 PUSHDATA gcd recorder-off ; 51 | clearstack 52 | T{ testgcd -> 7 }T 53 | 54 | \ test high level language Hello compiled to bitcoin script 55 | include hack.fs 56 | : testhack recorder-on hello_compiled recorder-off ; 57 | clearstack T{ testhack -> 5 }T 58 | -------------------------------------------------------------------------------- /src/app/test/testrecorder.fs: -------------------------------------------------------------------------------- 1 | \ testing words 2 | require ttester.fs 3 | 4 | \ simple add. 1 + 1 = 2 5 | : testadd recorder-on 1 PUSHDATA 1 PUSHDATA OP_ADD recorder-off ; 6 | : testadd_op recorder-on OP_1 OP_1 OP_ADD recorder-off ; 7 | clearstack T{ testadd -> 2 }T 8 | 9 | \ looping factorial 10 | \ notice I am only recording the necessary calculations for a thread of execution 11 | \ looping outer constructs are not getting recorded for these demos 12 | : fac 1 PUSHDATA swap 1+ 1 ?do i PUSHDATA OP_MUL loop ; 13 | : testfac recorder-on 5 fac recorder-off ; 14 | T{ 5 fac -> 120 }T 15 | clearstack T{ testfac -> 120 }T 16 | 17 | \ looping square root 18 | \ this is native forth implementation 19 | \ This implementation does not leave a clean stack on the bitcoin script side 20 | \ original forth 21 | \ : sqrt-closer ( square guess -- square guess adjustment) 2dup / over - 2 / ; 22 | \ : sqrt ( square -- root ) 1 begin sqrt-closer dup while + repeat drop nip ; 23 | \ : sqrt-closer ( square guess -- square guess adjustment) OP_2DUP OP_DIV OP_OVER OP_SUB OP_2DIV ; 24 | \ : sqrt ( square -- root ) OP_1 begin sqrt-closer OP_DUP while OP_ADD repeat OP_DROP OP_NIP ; 25 | 26 | : xnew ( n xold n xnew ) 27 | \ 2DUP / + 2/ ; 28 | OP_2DUP OP_DIV OP_ADD OP_2DIV ; 29 | 30 | \ This works for 9 and 81 but not 169? 31 | : sqrt ( n root ) 32 | \ DUP 1 > 33 | \ IF DUP 2/ ( n n/2 ) 10 0 DO XNEW LOOP NIP 34 | \ THEN ; 35 | OP_DUP OP_2DIV ( n n/2 ) 10 0 DO xnew LOOP OP_NIP 36 | ; 37 | 38 | : testsqrt recorder-on 9 PUSHDATA sqrt recorder-off ; 39 | clearstack T{ testsqrt -> 3 }T 40 | 41 | \ looping greatest common divisor 42 | : gcd ( a b -- n ) 43 | \ OP_2DUP <= if OP_SWAP ( Y X ) then 44 | begin 45 | OP_TUCK 46 | OP_MOD 47 | dup 48 | 0= until 49 | OP_DROP ; 50 | : testgcd recorder-on 105 PUSHDATA 28 PUSHDATA gcd recorder-off ; 51 | clearstack 52 | T{ testgcd -> 7 }T 53 | 54 | \ test high level language Hello compiled to bitcoin script 55 | \ include hack.fs 56 | \ : testhack recorder-on hello_compiled recorder-off ; 57 | \ clearstack T{ testhack -> 5 }T 58 | -------------------------------------------------------------------------------- /src/app/bitcoin-big.fs: -------------------------------------------------------------------------------- 1 | \ bitcoin script words with big nuber support 2 | require bitcoin-common.fs 3 | require lib/big.4th 4 | 5 | : OP_FALSE s" 0" make_big_number ; 6 | : OP_0 OP_FALSE 0x00 write ; 7 | \ should be 0x01 or true? 8 | \ or do we have to redefine forth true to be 0x01? 9 | : OP_TRUE s" 1" make_big_number ; 10 | : OP_1 OP_TRUE 0x51 write ; 11 | \ TODO: parse string slow. how to optimize? 12 | : OP_2 s" 2" make_big_number 0x52 write ; 13 | : OP_3 s" 3" make_big_number 0x53 write ; 14 | : OP_4 s" 4" make_big_number 0x54 write ; 15 | : OP_5 s" 5" make_big_number 0x55 write ; 16 | : OP_6 s" 6" make_big_number 0x56 write ; 17 | : OP_7 s" 7" make_big_number 0x57 write ; 18 | : OP_8 s" 8" make_big_number 0x58 write ; 19 | : OP_9 s" 9" make_big_number 0x59 write ; 20 | : OP_10 s" 10" make_big_number 0x5A write ; 21 | : OP_11 s" 11" make_big_number 0x5B write ; 22 | : OP_12 s" 12" make_big_number 0x5C write ; 23 | : OP_13 s" 13" make_big_number 0x5D write ; 24 | : OP_14 s" 14" make_big_number 0x5E write ; 25 | : OP_15 s" 15" make_big_number 0x5F write ; 26 | : OP_16 s" 16" make_big_number 0x60 write ; 27 | 28 | : OP_IFDUP ( If the top stack value is not 0, duplicate it.) 29 | dup big0<> if 30 | \ TODO: something wrong with big>here 31 | dup big>here here 32 | then 0x73 write ; 33 | 34 | : OP_EQUAL big= 0x87 write ; 35 | : OP_EQUALVERIFY big= bitcoin_verify 0x88 write ; 36 | 37 | \ If the input is 0 or 1, it is flipped. Otherwise the output will be 0. 38 | : OP_NOT 39 | big0= if 40 | s" 1" 41 | else 42 | s" 0" 43 | then 44 | make_big_number 45 | 0x91 write ; 46 | \ Returns 0 if the input is 0. 1 otherwise. 47 | : OP_0NOTEQUAL 48 | big0= if 49 | s" 0" 50 | else 51 | s" 1" 52 | then 53 | make_big_number 54 | 0x92 write ; 55 | 56 | : OP_WITHIN ( min max val -- true/false) 57 | dup ( min max val val) 58 | 3 roll ( max val val min) 59 | swap ( max val min val ) 60 | big< ( max val bool) 61 | invert if 62 | 2drop false 63 | else 64 | big< invert 65 | then 66 | 0xA5 write ; 67 | 68 | : OP_ADD big+ 0x93 write ; 69 | : OP_1ADD s" 1" make_big_number big+ 0x8B write ; 70 | 71 | 72 | -------------------------------------------------------------------------------- /hackathon/js/broadcaster.js: -------------------------------------------------------------------------------- 1 | 2 | // this app will read a tape (tape.txt) and put it on chain 3 | 4 | const axios = require('axios'); 5 | const bsv = require('bsv') 6 | const bsvMnemonic = require('bsv/mnemonic') 7 | const fs = require('fs') 8 | 9 | const tapefile = '../app/tape.txt' 10 | 11 | // if you get an error Cannot find module './wallet.json' 12 | // it is because wallet.json file is missing! 13 | // You can get one from https://tools.fullcyclemining.com/ 14 | // { 15 | // "mnemonic": "", 16 | // "wif": "", 17 | // "legacyAddress": "" 18 | // } 19 | const walletInfo = require(`./wallet.json`) 20 | 21 | function getPrivateKey() { 22 | var bsvpk 23 | if (walletInfo.wif) { 24 | console.log(`using wallet wif`) 25 | bsvpk = bsv.PrivateKey.fromWIF(walletInfo.wif) 26 | } else { 27 | console.log(`using wallet mnemonic`) 28 | const seed = new bsvMnemonic(walletInfo.mnemonic) 29 | const hdnode = seed.toHDPrivateKey('','testnet') 30 | //bsvpk = hdnode.privateKey 31 | bsvpk = hdnode.deriveChild(`m/44'/0'/0'`).privateKey 32 | } 33 | return bsvpk 34 | } 35 | 36 | async function explorer(url) { 37 | // fetch data from a url endpoint 38 | console.log(url) 39 | const response = await axios.get(url) 40 | const data = await response.data 41 | return data 42 | } 43 | 44 | function getTape() { 45 | return fs.readFileSync(tapefile, 'utf-8') 46 | } 47 | 48 | function storeTape() { 49 | // puts it into a tx and broadcasts 50 | const tape = getTape() 51 | if (tape) { 52 | console.log(tape) 53 | const tapeScript = bsv.Script.fromHex(tape) 54 | console.log(tapeScript.toString()) 55 | // https://test.whatsonchain.com/address/${fromAddress} 56 | // get private key from wallet 57 | const pk = getPrivateKey() 58 | const fromAddress = bsv.Address.fromPrivateKey(pk) 59 | 60 | const url_utxo = `https://api.whatsonchain.com/v1/bsv/test/address/${fromAddress}/unspent` 61 | 62 | ; (async () => { 63 | 64 | // get utxo from our wallet 65 | const utxos = await explorer(url_utxo) 66 | let fromUtxo 67 | // height, tx_pos, tx_hash, value 68 | // get the first utxo 69 | for (let i = 0; i { 125 | console.log(`${tapefile} file Changed`) 126 | storeTape() 127 | }) 128 | } else { 129 | storeTape() 130 | } 131 | } 132 | -------------------------------------------------------------------------------- /src/js/broadcaster.js: -------------------------------------------------------------------------------- 1 | 2 | // this app will read a tape (tape.txt) and put it on chain 3 | 4 | const axios = require('axios'); 5 | const bsv = require('bsv') 6 | const bsvMnemonic = require('bsv/mnemonic') 7 | const fs = require('fs') 8 | 9 | const tapefile = '../app/tape.txt' 10 | 11 | // if you get an error Cannot find module './wallet.json' 12 | // it is because wallet.json file is missing! 13 | // You can get one from https://tools.fullcyclemining.com/ 14 | // { 15 | // "mnemonic": "", 16 | // "wif": "", 17 | // "legacyAddress": "" 18 | // } 19 | const walletInfo = require(`./wallet.json.js`) 20 | 21 | function getPrivateKey() { 22 | var bsvpk 23 | if (walletInfo.wif) { 24 | console.log(`using wallet wif`) 25 | bsvpk = bsv.PrivateKey.fromWIF(walletInfo.wif) 26 | } else { 27 | console.log(`using wallet mnemonic`) 28 | const seed = new bsvMnemonic(walletInfo.mnemonic) 29 | const hdnode = seed.toHDPrivateKey('','testnet') 30 | //bsvpk = hdnode.privateKey 31 | bsvpk = hdnode.deriveChild(`m/44'/0'/0'`).privateKey 32 | } 33 | return bsvpk 34 | } 35 | 36 | async function explorer(url) { 37 | // fetch data from a url endpoint 38 | console.log(url) 39 | const response = await axios.get(url) 40 | const data = await response.data 41 | return data 42 | } 43 | 44 | function getTape() { 45 | return fs.readFileSync(tapefile, 'utf-8') 46 | } 47 | 48 | function storeTape() { 49 | // puts it into a tx and broadcasts 50 | const tape = getTape() 51 | if (tape) { 52 | console.log(tape) 53 | const tapeScript = bsv.Script.fromHex(tape) 54 | console.log(tapeScript.toString()) 55 | // https://test.whatsonchain.com/address/${fromAddress} 56 | // get private key from wallet 57 | const pk = getPrivateKey() 58 | const fromAddress = bsv.Address.fromPrivateKey(pk) 59 | 60 | const url_utxo = `https://api.whatsonchain.com/v1/bsv/test/address/${fromAddress}/unspent` 61 | 62 | ; (async () => { 63 | 64 | // get utxo from our wallet 65 | const utxos = await explorer(url_utxo) 66 | let fromUtxo 67 | // height, tx_pos, tx_hash, value 68 | // get the first utxo 69 | for (let i = 0; i { 125 | console.log(`${tapefile} file Changed`) 126 | storeTape() 127 | }) 128 | } else { 129 | storeTape() 130 | } 131 | } 132 | -------------------------------------------------------------------------------- /src/app/bitcoin.fs: -------------------------------------------------------------------------------- 1 | \ bitcoin opcodes implemented in forth 2 | \ 3 | \ TODO: handle strings as byte array or structure. 4 | \ string should be represented as one item on stack 5 | \ TODO: allow pushdata to handle multibyte data, for now assumes 1 byte 6 | \ i.e. get size of number on stack and handle endian conversion 7 | \ TODO: crypto functions, if needed, could be c or javascript interop 8 | \ TODO: handle IF/ELSE/ENDIF 9 | \ 10 | include functions.fs 11 | require bitcoin-common.fs 12 | 13 | : OP_FALSE false ; 14 | : OP_0 OP_FALSE 0x00 write ; 15 | \ should be 0x01 or true? 16 | \ or do we have to redefine forth true to be 0x01? 17 | : OP_TRUE 1 ; 18 | : OP_1 OP_TRUE 0x51 write ; 19 | : OP_2 2 0x52 write ; 20 | : OP_3 3 0x53 write ; 21 | : OP_4 4 0x54 write ; 22 | : OP_5 5 0x55 write ; 23 | : OP_6 6 0x56 write ; 24 | : OP_7 7 0x57 write ; 25 | : OP_8 8 0x58 write ; 26 | : OP_9 9 0x59 write ; 27 | : OP_10 10 0x5A write ; 28 | : OP_11 11 0x5B write ; 29 | : OP_12 12 0x5C write ; 30 | : OP_13 13 0x5D write ; 31 | : OP_14 14 0x5E write ; 32 | : OP_15 15 0x5F write ; 33 | : OP_16 16 0x60 write ; 34 | 35 | \ push specially encoded 0 through F onto stack 36 | : PUSH1HEX 37 | dup 38 | case 39 | 1 of drop OP_1 endof 40 | 2 of drop OP_2 endof 41 | 3 of drop OP_3 endof 42 | 4 of drop OP_4 endof 43 | 5 of drop OP_5 endof 44 | 6 of drop OP_6 endof 45 | 7 of drop OP_7 endof 46 | 8 of drop OP_8 endof 47 | 9 of drop OP_9 endof 48 | 10 of drop OP_10 endof 49 | 11 of drop OP_11 endof 50 | 12 of drop OP_12 endof 51 | 13 of drop OP_13 endof 52 | 14 of drop OP_14 endof 53 | 15 of drop OP_15 endof 54 | 16 of drop OP_16 endof 55 | s" PUSH1HEX bad value" exception throw 56 | endcase 57 | ; 58 | 59 | \ ( The next byte contains the number of bytes to be pushed onto the stack.) 60 | : OP_PUSHDATA1 0x4C write 61 | dup SizeOfNumberInBytes write 62 | \ push data, should enforce size is less than 256 63 | dup write 64 | ; 65 | 66 | \ ( The next two bytes contain the number of bytes to be pushed onto the stack in little endian order) 67 | : OP_PUSHDATA2 0x4D write 68 | s" not implemented yet" exception throw 69 | ; 70 | 71 | \ OP_PUSHDATA4 0x4E 72 | 73 | \ push minimally encoded data onto stack 74 | : PUSHDATA 75 | dup 0 < 76 | if 77 | \ TODO: handle negatives 78 | 0x01 write dup write 79 | else 80 | dup 16 <= 81 | if 82 | \ 0 - F 83 | PUSH1HEX 84 | else 85 | dup 0x4B <= 86 | if 87 | \ 10 - 4B 88 | 0x01 write dup write 89 | else 90 | dup SizeOfNumberInBytes 255 <= 91 | if 92 | \ Data size <= 255 bytes 93 | OP_PUSHDATA1 94 | else 95 | \ Data size > 255 bytes 96 | OP_PUSHDATA2 97 | then 98 | then 99 | then 100 | then 101 | ; 102 | 103 | : OP_1NEGATE -1 0x4F write ; 104 | \ TODO: how to do if/then 105 | : OP_IF 0x63 write ; 106 | \ OP_NOTIF 0x64 write ; 107 | \ OP_ELSE 0x67 write ; 108 | : OP_ENDIF 0x68 write ; 109 | \ Marks transaction as invalid if top stack value is not true. The top stack value is removed. 110 | : OP_VERIFY bitcoin_verify 0x69 write ; 111 | : OP_IFDUP ?dup 0x73 write ; ( If the top stack value is not 0, duplicate it.) 112 | 113 | \ ================ String Words ================= 114 | \ string handling in Forth is different than bitcoin. 115 | \ bitcoin script string is a misnomer. script really just manipulates arrays of bytes 116 | \ TODO: switch to a byte array implementation for working with bitcoin script, but allow forth strings for simplicity 117 | \ for now, think of these as hack ups to experiment with ideas for supporting strings or byte arrays 118 | 119 | \ a scratch pad for intermediate string results 120 | create scratch 256 allot 121 | 122 | : OP_CAT ( s1 s2 -- stringout) 123 | 2swap ( s2 s1) 124 | scratch place ( put s1 into scratch) 125 | scratch +place ( append s2 ) 126 | scratch count ( put s1+s2 back tos) 127 | 0x7E write ; 128 | 129 | \ bsv does not have substr, use split 130 | \ : OP_SUBSTR ( addr len begin size -- addr len ) 131 | \ \ use size as len 132 | \ 2 roll ( addr begin size len ) 133 | \ drop ( addr begin size ) 134 | \ \ add begin to addr 135 | \ swap ( addr size begin ) 136 | \ rot ( size begin addr) 137 | \ + ( size newaddr) 138 | \ swap ( newaddr size) 139 | 140 | \ Keeps only characters left of the specified point in a string 141 | : bitcoin_left ( addr len newsize -- addr newsize ) 142 | nip ( drop the old length and use the new one) 143 | ; 144 | 145 | \ Keeps only characters right of the specified point in a string. 146 | : bitcoin_right ( addr len size -- addr+size size ) 147 | dup >r ( addr len size) 148 | \ get difference 149 | - ( addr len-size) 150 | + ( newaddr ) 151 | \ use new size 152 | r> ( newaddr size) 153 | ; 154 | 155 | \ Splits a string, TODO: please refactor 156 | create scratch_split 256 allot 157 | : OP_SPLIT ( addr len num -- right left ) 158 | rot ( len num addr ) 159 | rot ( num addr len ) 160 | 2dup 161 | 2>r ( addr,len to alt stack ) 162 | 2 pick ( num addr len num ) 163 | swap ( num addr num len ) 164 | dup >r ( moves len to alt ) 165 | swap - ( num addr len-num ) 166 | r> swap ( num addr len len-num) 167 | bitcoin_right ( num right ) 168 | scratch_split place ( num ) 169 | 2r> ( num addr len ) 170 | rot ( addr len num ) 171 | bitcoin_left ( left ) 172 | scratch_split count ( left right ) 173 | 2swap ( right left ) 174 | 0x7F write ; 175 | 176 | : OP_NUM2BIN 177 | \ TODO 178 | \ Convert the numeric value into a byte sequence of a certain size, taking account of the sign bit. 179 | \ The byte sequence produced uses the little-endian encoding. 180 | \ 2 4 OP_NUM2BIN -> {0x02, 0x00, 0x00, 0x00} 181 | \ -5 4 OP_NUM2BIN -> {0x05, 0x00, 0x00, 0x80} 182 | 0x80 write ; 183 | 184 | : OP_BIN2NUM 185 | \ TODO 186 | \ Convert the byte sequence into a numeric value, including minimal encoding. 187 | \ The byte sequence must encode the value in little-endian encoding. 188 | \ {0x02, 0x00, 0x00, 0x00, 0x00} OP_BIN2NUM -> 2. 0x0200000000 in little-endian encoding has value 2. 189 | \ {0x05, 0x00, 0x80} OP_BIN2NUM -> -5 - 0x050080 in little-endian encoding has value -5. 190 | 0x81 write ; 191 | 192 | \ ( Pushes the string length of the top element of the stack (without popping it)) 193 | \ since Forth string is 2 stack items just need to dup the top of stack 194 | \ this will have to change! Need structure to represent a string as one stack item 195 | : OP_SIZE ( caddr nsize -- caddr nsize nsize) dup 0x82 write ; 196 | 197 | : OP_INVERT invert 0x83 write ; 198 | : OP_AND and 0x84 write ; 199 | : OP_OR or 0x85 write ; 200 | : OP_XOR xor 0x86 write ; 201 | : OP_EQUAL = 0x87 write ; 202 | : OP_EQUALVERIFY = bitcoin_verify 0x88 write ; 203 | : OP_1SUB 1 - 0x8C write ; 204 | : OP_MUL * 0x95 write ; 205 | : OP_DIV / 0x96 write ; 206 | \ 2mul is not implemented yet 207 | \ : OP_2MUL 2 * 0x8D write ; 208 | : OP_2MUL OP_2 OP_MUL ; 209 | \ : OP_2DIV 2/ 0x8E write ; 210 | : OP_2DIV OP_2 OP_DIV ; 211 | : OP_NEGATE negate 0x8F write ; 212 | : OP_ABS abs 0x90 write ; 213 | \ If the input is 0 or 1, it is flipped. Otherwise the output will be 0. 214 | : OP_NOT 215 | 0= if 216 | 1 217 | else 218 | 0 219 | then 220 | 0x91 write ; 221 | \ Returns 0 if the input is 0. 1 otherwise. 222 | : OP_0NOTEQUAL 223 | 0= if 224 | 0 225 | else 226 | 1 227 | then 228 | 0x92 write ; 229 | : OP_ADD + 0x93 write ; 230 | : OP_1ADD 1+ 0x8B write ; 231 | : OP_SUB - 0x94 write ; 232 | : OP_MOD mod 0x97 write ; 233 | : OP_LSHIFT lshift 0x98 write ; 234 | : OP_RSHIFT rshift 0x99 write ; 235 | : OP_BOOLAND and 0x9A write ; ( should check that params are bool true or false) 236 | : OP_BOOLOR or 0x9B write ; ( should check that params are bool true or false) 237 | : OP_NUMEQUAL = 0x9C write ; 238 | : OP_NUMEQUALVERIFY = bitcoin_verify 0x9D write ; 239 | : OP_NUMNOTEQUAL <> 0x9E write ; 240 | : OP_LESSTHAN < 0x9F write ; 241 | : OP_GREATERTHAN > 0xA0 write ; 242 | : OP_LESSTHANOREQUAL <= 0xA1 write ; 243 | : OP_GREATERTHANOREQUAL >= 0xA2 write ; 244 | : OP_MIN min 0xA3 write ; 245 | : OP_MAX max 0xA4 write ; 246 | : OP_WITHIN within 0xA5 write ; 247 | 248 | \ OP_RIPEMD160 0xA6 249 | \ OP_SHA1 0xA7 250 | \ OP_SHA256 0xA8 251 | \ OP_HASH160 0xA9 252 | \ OP_HASH256 0xAA 253 | \ OP_CHECKSIG 0xAC 254 | \ OP_CHECKSIGVERIFY 0xAD 255 | \ OP_CHECKMULTISIG 0xAE 256 | \ OP_CHECKMULTISIGVERIFY 0xAF 257 | \ OP_CHECKLOCKTIMEVERIFY 0xB1 258 | \ OP_CHECKSEQUENCEVERIFY 0xB2 259 | \ OP_PUBKEYHASH 0xFD 260 | \ OP_PUBKEY 0xFE 261 | : OP_INVALIDOPCODE 0xFF write ; 262 | : OP_RESERVED 0x50 write ; 263 | \ OP_VER 0x62 264 | \ OP_VERIF 0x65 265 | \ OP_VERIFNOT 0x66 266 | \ OP_RESERVED1 0x89 267 | \ OP_RESERVED2 0x8A 268 | : OP_NOP1 0xB0 write ; 269 | -------------------------------------------------------------------------------- /hackathon/app/bitcoin.fs: -------------------------------------------------------------------------------- 1 | \ bitcoin opcodes implemented in forth 2 | \ 3 | \ TODO: handle strings as byte array or structure. 4 | \ string should be represented as one item on stack 5 | \ TODO: allow pushdata to handle multibyte data, for now assumes 1 byte 6 | \ i.e. get size of number on stack and handle endian conversion 7 | \ TODO: crypto functions, if needed, could be c or javascript interop 8 | \ TODO: handle IF/ELSE/ENDIF 9 | \ 10 | include functions.fs 11 | 12 | include altstack.fs 13 | \ defines altstack named alt with only 10 capacity 14 | 10 altstack alt 15 | 16 | : bitcoin_verify 17 | true <> if 18 | assert( false ) 19 | then 20 | ; 21 | 22 | : OP_FALSE false ; 23 | : OP_0 OP_FALSE 0x00 write ; 24 | \ should be 0x01 or true? 25 | \ or do we have to redefine forth true to be 0x01? 26 | : OP_TRUE 1 ; 27 | : OP_1 OP_TRUE 0x51 write ; 28 | : OP_2 2 0x52 write ; 29 | : OP_3 3 0x53 write ; 30 | : OP_4 4 0x54 write ; 31 | : OP_5 5 0x55 write ; 32 | : OP_6 6 0x56 write ; 33 | : OP_7 7 0x57 write ; 34 | : OP_8 8 0x58 write ; 35 | : OP_9 9 0x59 write ; 36 | : OP_10 10 0x5A write ; 37 | : OP_11 11 0x5B write ; 38 | : OP_12 12 0x5C write ; 39 | : OP_13 13 0x5D write ; 40 | : OP_14 14 0x5E write ; 41 | : OP_15 15 0x5F write ; 42 | : OP_16 16 0x60 write ; 43 | : OP_NOP 0x61 write ; 44 | 45 | \ push specially encoded 0 through F onto stack 46 | : PUSH1HEX 47 | dup 48 | case 49 | 1 of drop OP_1 endof 50 | 2 of drop OP_2 endof 51 | 3 of drop OP_3 endof 52 | 4 of drop OP_4 endof 53 | 5 of drop OP_5 endof 54 | 6 of drop OP_6 endof 55 | 7 of drop OP_7 endof 56 | 8 of drop OP_8 endof 57 | 9 of drop OP_9 endof 58 | 10 of drop OP_10 endof 59 | 11 of drop OP_11 endof 60 | 12 of drop OP_12 endof 61 | 13 of drop OP_13 endof 62 | 14 of drop OP_14 endof 63 | 15 of drop OP_15 endof 64 | 16 of drop OP_16 endof 65 | s" PUSH1HEX bad value" exception throw 66 | endcase 67 | ; 68 | 69 | \ ( The next byte contains the number of bytes to be pushed onto the stack.) 70 | : OP_PUSHDATA1 0x4C write 71 | dup SizeOfNumberInBytes write 72 | \ push data, should enforce size is less than 256 73 | dup write 74 | ; 75 | 76 | \ ( The next two bytes contain the number of bytes to be pushed onto the stack in little endian order) 77 | : OP_PUSHDATA2 0x4D write 78 | s" not implemented yet" exception throw 79 | ; 80 | 81 | \ OP_PUSHDATA4 0x4E 82 | 83 | \ push minimally encoded data onto stack 84 | : PUSHDATA 85 | dup 0 < 86 | if 87 | \ TODO: handle negatives 88 | 0x01 write dup write 89 | else 90 | dup 16 <= 91 | if 92 | \ 0 - F 93 | PUSH1HEX 94 | else 95 | dup 0x4B <= 96 | if 97 | \ 10 - 4B 98 | 0x01 write dup write 99 | else 100 | dup SizeOfNumberInBytes 255 <= 101 | if 102 | \ Data size <= 255 bytes 103 | OP_PUSHDATA1 104 | else 105 | \ Data size > 255 bytes 106 | OP_PUSHDATA2 107 | then 108 | then 109 | then 110 | then 111 | ; 112 | 113 | : OP_1NEGATE -1 0x4F write ; 114 | \ TODO: how to do if/then 115 | : OP_IF 0x63 write ; 116 | \ OP_NOTIF 0x64 write ; 117 | \ OP_ELSE 0x67 write ; 118 | : OP_ENDIF 0x68 write ; 119 | \ Marks transaction as invalid if top stack value is not true. The top stack value is removed. 120 | : OP_VERIFY bitcoin_verify 0x69 write ; 121 | 122 | \ =============== Stack words ============================ 123 | \ has to consume TOS according to new specification 124 | : OP_RETURN drop 0x6A write ; 125 | : OP_TOALTSTACK alt altpush 0x6B write ; 126 | : OP_FROMALTSTACK alt altpop 0x6C write ; 127 | : OP_IFDUP ?dup 0x73 write ; ( If the top stack value is not 0, duplicate it.) 128 | : OP_DEPTH depth 0x74 write ; 129 | : OP_DROP drop 0x75 write ; 130 | : OP_DUP dup 0x76 write ; 131 | : OP_NIP nip 0x77 write ; 132 | : OP_OVER over 0x78 write ; 133 | : OP_PICK pick 0x79 write ; 134 | : OP_ROLL roll 0x7A write ; 135 | : OP_ROT rot 0x7B write ; 136 | : OP_SWAP swap 0x7C write ; 137 | : OP_TUCK tuck 0x7D write ; 138 | : OP_2DROP 2drop 0x6D write ; 139 | : OP_2DUP 2dup 0x6E write ; 140 | : OP_3DUP dup 2over rot 0x6F write ; 141 | : OP_2OVER 2over 0x70 write ; 142 | : OP_2ROT 2rot 0x71 write ; 143 | : OP_2SWAP 2swap 0x72 write ; 144 | 145 | \ ================ String Words ================= 146 | \ string handling in Forth is different than bitcoin. 147 | \ bitcoin script string is a misnomer. script really just manipulates arrays of bytes 148 | \ TODO: switch to a byte array implementation for working with bitcoin script, but allow forth strings for simplicity 149 | \ for now, think of these as hack ups to experiment with ideas for supporting strings or byte arrays 150 | 151 | \ a scratch pad for intermediate string results 152 | create scratch 256 allot 153 | 154 | : OP_CAT ( s1 s2 -- stringout) 155 | 2swap ( s2 s1) 156 | scratch place ( put s1 into scratch) 157 | scratch +place ( append s2 ) 158 | scratch count ( put s1+s2 back tos) 159 | 0x7E write ; 160 | 161 | \ bsv does not have substr, use split 162 | \ : OP_SUBSTR ( addr len begin size -- addr len ) 163 | \ \ use size as len 164 | \ 2 roll ( addr begin size len ) 165 | \ drop ( addr begin size ) 166 | \ \ add begin to addr 167 | \ swap ( addr size begin ) 168 | \ rot ( size begin addr) 169 | \ + ( size newaddr) 170 | \ swap ( newaddr size) 171 | 172 | \ Keeps only characters left of the specified point in a string 173 | : bitcoin_left ( addr len newsize -- addr newsize ) 174 | nip ( drop the old length and use the new one) 175 | ; 176 | 177 | \ Keeps only characters right of the specified point in a string. 178 | : bitcoin_right ( addr len size -- addr+size size ) 179 | dup >r ( addr len size) 180 | \ get difference 181 | - ( addr len-size) 182 | + ( newaddr ) 183 | \ use new size 184 | r> ( newaddr size) 185 | ; 186 | 187 | \ Splits a string, TODO: please refactor 188 | create scratch_split 256 allot 189 | : OP_SPLIT ( addr len num -- right left ) 190 | rot ( len num addr ) 191 | rot ( num addr len ) 192 | 2dup 193 | 2>r ( addr,len to alt stack ) 194 | 2 pick ( num addr len num ) 195 | swap ( num addr num len ) 196 | dup >r ( moves len to alt ) 197 | swap - ( num addr len-num ) 198 | r> swap ( num addr len len-num) 199 | bitcoin_right ( num right ) 200 | scratch_split place ( num ) 201 | 2r> ( num addr len ) 202 | rot ( addr len num ) 203 | bitcoin_left ( left ) 204 | scratch_split count ( left right ) 205 | 2swap ( right left ) 206 | 0x7F write ; 207 | 208 | : OP_NUM2BIN 209 | \ TODO 210 | \ Convert the numeric value into a byte sequence of a certain size, taking account of the sign bit. 211 | \ The byte sequence produced uses the little-endian encoding. 212 | \ 2 4 OP_NUM2BIN -> {0x02, 0x00, 0x00, 0x00} 213 | \ -5 4 OP_NUM2BIN -> {0x05, 0x00, 0x00, 0x80} 214 | 0x80 write ; 215 | 216 | : OP_BIN2NUM 217 | \ TODO 218 | \ Convert the byte sequence into a numeric value, including minimal encoding. 219 | \ The byte sequence must encode the value in little-endian encoding. 220 | \ {0x02, 0x00, 0x00, 0x00, 0x00} OP_BIN2NUM -> 2. 0x0200000000 in little-endian encoding has value 2. 221 | \ {0x05, 0x00, 0x80} OP_BIN2NUM -> -5 - 0x050080 in little-endian encoding has value -5. 222 | 0x81 write ; 223 | 224 | \ ( Pushes the string length of the top element of the stack (without popping it)) 225 | \ since Forth string is 2 stack items just need to dup the top of stack 226 | \ this will have to change! Need structure to represent a string as one stack item 227 | : OP_SIZE ( caddr nsize -- caddr nsize nsize) dup 0x82 write ; 228 | 229 | : OP_INVERT invert 0x83 write ; 230 | : OP_AND and 0x84 write ; 231 | : OP_OR or 0x85 write ; 232 | : OP_XOR xor 0x86 write ; 233 | : OP_EQUAL = 0x87 write ; 234 | : OP_EQUALVERIFY = bitcoin_verify 0x88 write ; 235 | : OP_1SUB 1 - 0x8C write ; 236 | : OP_MUL * 0x95 write ; 237 | : OP_DIV / 0x96 write ; 238 | \ 2mul is not implemented yet 239 | \ : OP_2MUL 2 * 0x8D write ; 240 | : OP_2MUL OP_2 OP_MUL ; 241 | \ : OP_2DIV 2/ 0x8E write ; 242 | : OP_2DIV OP_2 OP_DIV ; 243 | : OP_NEGATE negate 0x8F write ; 244 | : OP_ABS abs 0x90 write ; 245 | \ If the input is 0 or 1, it is flipped. Otherwise the output will be 0. 246 | : OP_NOT 247 | 0= if 248 | 1 249 | else 250 | 0 251 | then 252 | 0x91 write ; 253 | \ Returns 0 if the input is 0. 1 otherwise. 254 | : OP_0NOTEQUAL 255 | 0= if 256 | 0 257 | else 258 | 1 259 | then 260 | 0x92 write ; 261 | : OP_ADD + 0x93 write ; 262 | : OP_1ADD 1+ 0x8B write ; 263 | : OP_SUB - 0x94 write ; 264 | : OP_MOD mod 0x97 write ; 265 | : OP_LSHIFT lshift 0x98 write ; 266 | : OP_RSHIFT rshift 0x99 write ; 267 | : OP_BOOLAND and 0x9A write ; ( should check that params are bool true or false) 268 | : OP_BOOLOR or 0x9B write ; ( should check that params are bool true or false) 269 | : OP_NUMEQUAL = 0x9C write ; 270 | : OP_NUMEQUALVERIFY = bitcoin_verify 0x9D write ; 271 | : OP_NUMNOTEQUAL <> 0x9E write ; 272 | : OP_LESSTHAN < 0x9F write ; 273 | : OP_GREATERTHAN > 0xA0 write ; 274 | : OP_LESSTHANOREQUAL <= 0xA1 write ; 275 | : OP_GREATERTHANOREQUAL >= 0xA2 write ; 276 | : OP_MIN min 0xA3 write ; 277 | : OP_MAX max 0xA4 write ; 278 | : OP_WITHIN within 0xA5 write ; 279 | \ OP_RIPEMD160 0xA6 280 | \ OP_SHA1 0xA7 281 | \ OP_SHA256 0xA8 282 | \ OP_HASH160 0xA9 283 | \ OP_HASH256 0xAA 284 | : OP_CODESEPARATOR 0xAB write ; 285 | \ OP_CHECKSIG 0xAC 286 | \ OP_CHECKSIGVERIFY 0xAD 287 | \ OP_CHECKMULTISIG 0xAE 288 | \ OP_CHECKMULTISIGVERIFY 0xAF 289 | \ OP_CHECKLOCKTIMEVERIFY 0xB1 290 | \ OP_CHECKSEQUENCEVERIFY 0xB2 291 | \ OP_PUBKEYHASH 0xFD 292 | \ OP_PUBKEY 0xFE 293 | : OP_INVALIDOPCODE 0xFF write ; 294 | : OP_RESERVED 0x50 write ; 295 | \ OP_VER 0x62 296 | \ OP_VERIF 0x65 297 | \ OP_VERIFNOT 0x66 298 | \ OP_RESERVED1 0x89 299 | \ OP_RESERVED2 0x8A 300 | : OP_NOP1 0xB0 write ; 301 | 302 | \ dummy opcodes. 303 | \ Forth while loop consumes TOS 304 | : OP_WHILE drop ; 305 | \ 306 | : bitcoin_drop drop ; -------------------------------------------------------------------------------- /hackathon/app/ttester.fs: -------------------------------------------------------------------------------- 1 | \ This file contains the code for ttester, a utility for testing Forth words, 2 | \ as developed by several authors (see below), together with some explanations 3 | \ of its use. 4 | 5 | \ ttester is based on the original tester suite by Hayes: 6 | \ From: John Hayes S1I 7 | \ Subject: tester.fr 8 | \ Date: Mon, 27 Nov 95 13:10:09 PST 9 | \ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY 10 | \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS. 11 | \ VERSION 1.1 12 | \ All the subsequent changes have been placed in the public domain. 13 | \ The primary changes from the original are the replacement of "{" by "T{" 14 | \ and "}" by "}T" (to avoid conflicts with the uses of { for locals and } 15 | \ for FSL arrays), modifications so that the stack is allowed to be non-empty 16 | \ before T{, and extensions for the handling of floating point tests. 17 | \ Code for testing equality of floating point values comes 18 | \ from ftester.fs written by David N. Williams, based on the idea of 19 | \ approximate equality in Dirk Zoller's float.4th. 20 | \ Further revisions were provided by Anton Ertl, including the ability 21 | \ to handle either integrated or separate floating point stacks. 22 | \ Revision history and possibly newer versions can be found at 23 | \ http://www.complang.tuwien.ac.at/cvsweb/cgi-bin/cvsweb/gforth/test/ttester.fs 24 | \ Explanatory material and minor reformatting (no code changes) by 25 | \ C. G. Montgomery March 2009, with helpful comments from David Williams 26 | \ and Krishna Myneni. 27 | 28 | \ Usage: 29 | 30 | \ The basic usage takes the form T{ -> }T . 31 | \ This executes and compares the resulting stack contents with 32 | \ the values, and reports any discrepancy between the 33 | \ two sets of values. 34 | \ For example: 35 | \ T{ 1 2 3 swap -> 1 3 2 }T ok 36 | \ T{ 1 2 3 swap -> 1 2 2 }T INCORRECT RESULT: T{ 1 2 3 swap -> 1 2 2 }T ok 37 | \ T{ 1 2 3 swap -> 1 2 }T WRONG NUMBER OF RESULTS: T{ 1 2 3 swap -> 1 2 }T ok 38 | 39 | \ Floating point testing can involve further complications. The code 40 | \ attempts to determine whether floating-point support is present, and 41 | \ if so, whether there is a separate floating-point stack, and behave 42 | \ accordingly. The CONSTANTs HAS-FLOATING and HAS-FLOATING-STACK 43 | \ contain the results of its efforts, so the behavior of the code can 44 | \ be modified by the user if necessary. 45 | 46 | \ Then there are the perennial issues of floating point value 47 | \ comparisons. Exact equality is specified by SET-EXACT (the 48 | \ default). If approximate equality tests are desired, execute 49 | \ SET-NEAR . Then the FVARIABLEs REL-NEAR (default 1E-12) and 50 | \ ABS-NEAR (default 0E) contain the values to be used in comparisons 51 | \ by the (internal) word FNEARLY= . 52 | 53 | \ When there is not a separate floating point stack and you want to 54 | \ use approximate equality for FP values, it is necessary to identify 55 | \ which stack items are floating point quantities. This can be done 56 | \ by replacing the closing }T with a version that specifies this, such 57 | \ as RRXR}T which identifies the stack picture ( r r x r ). The code 58 | \ provides such words for all combinations of R and X with up to four 59 | \ stack items. They can be used with either an integrated or separate 60 | \ floating point stacks. Adding more if you need them is 61 | \ straightforward; see the examples in the source. Here is an example 62 | \ which also illustrates controlling the precision of comparisons: 63 | 64 | \ SET-NEAR 65 | \ 1E-6 REL-NEAR F! 66 | \ T{ S" 3.14159E" >FLOAT -> -1E FACOS TRUE RX}T 67 | 68 | \ The word ERROR is now vectored, so that its action can be changed by 69 | \ the user (for example, to add a counter for the number of errors). 70 | \ The default action ERROR1 can be used as a factor in the display of 71 | \ error reports. 72 | 73 | \ Loading ttester.fs does not change BASE. Remember that floating point input 74 | \ is ambiguous if the base is not decimal. 75 | 76 | \ The file defines some 70 words in all, but in most cases only the 77 | \ ones mentioned above will be needed for successful testing. 78 | 79 | BASE @ 80 | DECIMAL 81 | 82 | VARIABLE ACTUAL-DEPTH \ stack record 83 | CREATE ACTUAL-RESULTS 32 CELLS ALLOT 84 | VARIABLE START-DEPTH 85 | VARIABLE XCURSOR \ for ...}T 86 | VARIABLE ERROR-XT 87 | 88 | : ERROR ERROR-XT @ EXECUTE ; \ for vectoring of error reporting 89 | 90 | : "FLOATING" S" FLOATING" ; \ only compiled S" in CORE 91 | : "FLOATING-STACK" S" FLOATING-STACK" ; 92 | "FLOATING" ENVIRONMENT? [IF] 93 | [IF] 94 | TRUE 95 | [ELSE] 96 | FALSE 97 | [THEN] 98 | [ELSE] 99 | FALSE 100 | [THEN] CONSTANT HAS-FLOATING 101 | "FLOATING-STACK" ENVIRONMENT? [IF] 102 | [IF] 103 | TRUE 104 | [ELSE] 105 | FALSE 106 | [THEN] 107 | [ELSE] \ We don't know whether the FP stack is separate. 108 | HAS-FLOATING \ If we have FLOATING, we assume it is. 109 | [THEN] CONSTANT HAS-FLOATING-STACK 110 | 111 | HAS-FLOATING [IF] 112 | \ Set the following to the relative and absolute tolerances you 113 | \ want for approximate float equality, to be used with F~ in 114 | \ FNEARLY=. Keep the signs, because F~ needs them. 115 | FVARIABLE REL-NEAR 1E-12 REL-NEAR F! 116 | FVARIABLE ABS-NEAR 0E ABS-NEAR F! 117 | 118 | \ When EXACT? is TRUE, }F uses FEXACTLY=, otherwise FNEARLY=. 119 | 120 | TRUE VALUE EXACT? 121 | : SET-EXACT ( -- ) TRUE TO EXACT? ; 122 | : SET-NEAR ( -- ) FALSE TO EXACT? ; 123 | 124 | : FEXACTLY= ( F: X Y -- S: FLAG ) 125 | ( 126 | Leave TRUE if the two floats are identical. 127 | ) 128 | 0E F~ ; 129 | 130 | : FABS= ( F: X Y -- S: FLAG ) 131 | ( 132 | Leave TRUE if the two floats are equal within the tolerance 133 | stored in ABS-NEAR. 134 | ) 135 | ABS-NEAR F@ F~ ; 136 | 137 | : FREL= ( F: X Y -- S: FLAG ) 138 | ( 139 | Leave TRUE if the two floats are relatively equal based on the 140 | tolerance stored in ABS-NEAR. 141 | ) 142 | REL-NEAR F@ FNEGATE F~ ; 143 | 144 | : F2DUP FOVER FOVER ; 145 | : F2DROP FDROP FDROP ; 146 | 147 | : FNEARLY= ( F: X Y -- S: FLAG ) 148 | ( 149 | Leave TRUE if the two floats are nearly equal. This is a 150 | refinement of Dirk Zoller's FEQ to also allow X = Y, including 151 | both zero, or to allow approximately equality when X and Y are too 152 | small to satisfy the relative approximation mode in the F~ 153 | specification. 154 | ) 155 | F2DUP FEXACTLY= IF F2DROP TRUE EXIT THEN 156 | F2DUP FREL= IF F2DROP TRUE EXIT THEN 157 | FABS= ; 158 | 159 | : FCONF= ( R1 R2 -- F ) 160 | EXACT? IF 161 | FEXACTLY= 162 | ELSE 163 | FNEARLY= 164 | THEN ; 165 | [THEN] 166 | 167 | HAS-FLOATING-STACK [IF] 168 | VARIABLE ACTUAL-FDEPTH 169 | CREATE ACTUAL-FRESULTS 32 FLOATS ALLOT 170 | VARIABLE START-FDEPTH 171 | VARIABLE FCURSOR 172 | 173 | : EMPTY-FSTACK ( ... -- ... ) 174 | FDEPTH START-FDEPTH @ < IF 175 | FDEPTH START-FDEPTH @ SWAP DO 0E LOOP 176 | THEN 177 | FDEPTH START-FDEPTH @ > IF 178 | FDEPTH START-FDEPTH @ DO FDROP LOOP 179 | THEN ; 180 | 181 | : F{ ( -- ) 182 | FDEPTH START-FDEPTH ! 0 FCURSOR ! ; 183 | 184 | : F-> ( ... -- ... ) 185 | FDEPTH DUP ACTUAL-FDEPTH ! 186 | START-FDEPTH @ > IF 187 | FDEPTH START-FDEPTH @ - 0 DO ACTUAL-FRESULTS I FLOATS + F! LOOP 188 | THEN ; 189 | 190 | : F} ( ... -- ... ) 191 | FDEPTH ACTUAL-FDEPTH @ = IF 192 | FDEPTH START-FDEPTH @ > IF 193 | FDEPTH START-FDEPTH @ - 0 DO 194 | ACTUAL-FRESULTS I FLOATS + F@ FCONF= INVERT IF 195 | S" INCORRECT FP RESULT: " ERROR LEAVE 196 | THEN 197 | LOOP 198 | THEN 199 | ELSE 200 | S" WRONG NUMBER OF FP RESULTS: " ERROR 201 | THEN ; 202 | 203 | : F...}T ( -- ) 204 | FCURSOR @ START-FDEPTH @ + ACTUAL-FDEPTH @ <> IF 205 | S" NUMBER OF FLOAT RESULTS BEFORE '->' DOES NOT MATCH ...}T SPECIFICATION: " ERROR 206 | ELSE FDEPTH START-FDEPTH @ = 0= IF 207 | S" NUMBER OF FLOAT RESULTS BEFORE AND AFTER '->' DOES NOT MATCH: " ERROR 208 | THEN THEN ; 209 | 210 | 211 | : FTESTER ( R -- ) 212 | FDEPTH 0= ACTUAL-FDEPTH @ FCURSOR @ START-FDEPTH @ + 1+ < OR IF 213 | S" NUMBER OF FLOAT RESULTS AFTER '->' BELOW ...}T SPECIFICATION: " ERROR 214 | ELSE ACTUAL-FRESULTS FCURSOR @ FLOATS + F@ FCONF= 0= IF 215 | S" INCORRECT FP RESULT: " ERROR 216 | THEN THEN 217 | 1 FCURSOR +! ; 218 | 219 | [ELSE] 220 | : EMPTY-FSTACK ; 221 | : F{ ; 222 | : F-> ; 223 | : F} ; 224 | : F...}T ; 225 | 226 | HAS-FLOATING [IF] 227 | : COMPUTE-CELLS-PER-FP ( -- U ) 228 | DEPTH 0E DEPTH 1- >R FDROP R> SWAP - ; 229 | 230 | COMPUTE-CELLS-PER-FP CONSTANT CELLS-PER-FP 231 | 232 | : FTESTER ( R -- ) 233 | DEPTH CELLS-PER-FP < ACTUAL-DEPTH @ XCURSOR @ START-DEPTH @ + CELLS-PER-FP + < OR IF 234 | S" NUMBER OF RESULTS AFTER '->' BELOW ...}T SPECIFICATION: " ERROR EXIT 235 | ELSE ACTUAL-RESULTS XCURSOR @ CELLS + F@ FCONF= 0= IF 236 | S" INCORRECT FP RESULT: " ERROR 237 | THEN THEN 238 | CELLS-PER-FP XCURSOR +! ; 239 | [THEN] 240 | [THEN] 241 | 242 | : EMPTY-STACK \ ( ... -- ) empty stack; handles underflowed stack too. 243 | DEPTH START-DEPTH @ < IF 244 | DEPTH START-DEPTH @ SWAP DO 0 LOOP 245 | THEN 246 | DEPTH START-DEPTH @ > IF 247 | DEPTH START-DEPTH @ DO DROP LOOP 248 | THEN 249 | EMPTY-FSTACK ; 250 | 251 | : ERROR1 \ ( C-ADDR U -- ) display an error message 252 | \ followed by the line that had the error. 253 | TYPE SOURCE TYPE CR \ display line corresponding to error 254 | EMPTY-STACK \ throw away everything else 255 | ; 256 | 257 | ' ERROR1 ERROR-XT ! 258 | 259 | : T{ \ ( -- ) syntactic sugar. 260 | DEPTH START-DEPTH ! 0 XCURSOR ! F{ ; 261 | 262 | : -> \ ( ... -- ) record depth and contents of stack. 263 | DEPTH DUP ACTUAL-DEPTH ! \ record depth 264 | START-DEPTH @ > IF \ if there is something on the stack 265 | DEPTH START-DEPTH @ - 0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ save them 266 | THEN 267 | F-> ; 268 | 269 | : }T \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED 270 | \ (ACTUAL) CONTENTS. 271 | DEPTH ACTUAL-DEPTH @ = IF \ if depths match 272 | DEPTH START-DEPTH @ > IF \ if there is something on the stack 273 | DEPTH START-DEPTH @ - 0 DO \ for each stack item 274 | ACTUAL-RESULTS I CELLS + @ \ compare actual with expected 275 | <> IF S" INCORRECT RESULT: " ERROR LEAVE THEN 276 | LOOP 277 | THEN 278 | ELSE \ depth mismatch 279 | S" WRONG NUMBER OF RESULTS: " ERROR 280 | THEN 281 | F} ; 282 | 283 | : ...}T ( -- ) 284 | XCURSOR @ START-DEPTH @ + ACTUAL-DEPTH @ <> IF 285 | S" NUMBER OF CELL RESULTS BEFORE '->' DOES NOT MATCH ...}T SPECIFICATION: " ERROR 286 | ELSE DEPTH START-DEPTH @ = 0= IF 287 | S" NUMBER OF CELL RESULTS BEFORE AND AFTER '->' DOES NOT MATCH: " ERROR 288 | THEN THEN 289 | F...}T ; 290 | 291 | : XTESTER ( X -- ) 292 | DEPTH 0= ACTUAL-DEPTH @ XCURSOR @ START-DEPTH @ + 1+ < OR IF 293 | S" NUMBER OF CELL RESULTS AFTER '->' BELOW ...}T SPECIFICATION: " ERROR EXIT 294 | ELSE ACTUAL-RESULTS XCURSOR @ CELLS + @ <> IF 295 | S" INCORRECT CELL RESULT: " ERROR 296 | THEN THEN 297 | 1 XCURSOR +! ; 298 | 299 | : X}T XTESTER ...}T ; 300 | : XX}T XTESTER XTESTER ...}T ; 301 | : XXX}T XTESTER XTESTER XTESTER ...}T ; 302 | : XXXX}T XTESTER XTESTER XTESTER XTESTER ...}T ; 303 | 304 | HAS-FLOATING [IF] 305 | : R}T FTESTER ...}T ; 306 | : XR}T FTESTER XTESTER ...}T ; 307 | : RX}T XTESTER FTESTER ...}T ; 308 | : RR}T FTESTER FTESTER ...}T ; 309 | : XXR}T FTESTER XTESTER XTESTER ...}T ; 310 | : XRX}T XTESTER FTESTER XTESTER ...}T ; 311 | : XRR}T FTESTER FTESTER XTESTER ...}T ; 312 | : RXX}T XTESTER XTESTER FTESTER ...}T ; 313 | : RXR}T FTESTER XTESTER FTESTER ...}T ; 314 | : RRX}T XTESTER FTESTER FTESTER ...}T ; 315 | : RRR}T FTESTER FTESTER FTESTER ...}T ; 316 | : XXXR}T FTESTER XTESTER XTESTER XTESTER ...}T ; 317 | : XXRX}T XTESTER FTESTER XTESTER XTESTER ...}T ; 318 | : XXRR}T FTESTER FTESTER XTESTER XTESTER ...}T ; 319 | : XRXX}T XTESTER XTESTER FTESTER XTESTER ...}T ; 320 | : XRXR}T FTESTER XTESTER FTESTER XTESTER ...}T ; 321 | : XRRX}T XTESTER FTESTER FTESTER XTESTER ...}T ; 322 | : XRRR}T FTESTER FTESTER FTESTER XTESTER ...}T ; 323 | : RXXX}T XTESTER XTESTER XTESTER FTESTER ...}T ; 324 | : RXXR}T FTESTER XTESTER XTESTER FTESTER ...}T ; 325 | : RXRX}T XTESTER FTESTER XTESTER FTESTER ...}T ; 326 | : RXRR}T FTESTER FTESTER XTESTER FTESTER ...}T ; 327 | : RRXX}T XTESTER XTESTER FTESTER FTESTER ...}T ; 328 | : RRXR}T FTESTER XTESTER FTESTER FTESTER ...}T ; 329 | : RRRX}T XTESTER FTESTER FTESTER FTESTER ...}T ; 330 | : RRRR}T FTESTER FTESTER FTESTER FTESTER ...}T ; 331 | [THEN] 332 | 333 | \ Set the following flag to TRUE for more verbose output; this may 334 | \ allow you to tell which test caused your system to hang. 335 | VARIABLE VERBOSE 336 | FALSE VERBOSE ! 337 | 338 | : TESTING \ ( -- ) TALKING COMMENT. 339 | SOURCE VERBOSE @ 340 | IF DUP >R TYPE CR R> >IN ! 341 | ELSE >IN ! DROP 342 | THEN ; 343 | 344 | BASE ! 345 | \ end of ttester.fs -------------------------------------------------------------------------------- /src/app/test/ttester.fs: -------------------------------------------------------------------------------- 1 | \ This file contains the code for ttester, a utility for testing Forth words, 2 | \ as developed by several authors (see below), together with some explanations 3 | \ of its use. 4 | 5 | \ ttester is based on the original tester suite by Hayes: 6 | \ From: John Hayes S1I 7 | \ Subject: tester.fr 8 | \ Date: Mon, 27 Nov 95 13:10:09 PST 9 | \ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY 10 | \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS. 11 | \ VERSION 1.1 12 | \ All the subsequent changes have been placed in the public domain. 13 | \ The primary changes from the original are the replacement of "{" by "T{" 14 | \ and "}" by "}T" (to avoid conflicts with the uses of { for locals and } 15 | \ for FSL arrays), modifications so that the stack is allowed to be non-empty 16 | \ before T{, and extensions for the handling of floating point tests. 17 | \ Code for testing equality of floating point values comes 18 | \ from ftester.fs written by David N. Williams, based on the idea of 19 | \ approximate equality in Dirk Zoller's float.4th. 20 | \ Further revisions were provided by Anton Ertl, including the ability 21 | \ to handle either integrated or separate floating point stacks. 22 | \ Revision history and possibly newer versions can be found at 23 | \ http://www.complang.tuwien.ac.at/cvsweb/cgi-bin/cvsweb/gforth/test/ttester.fs 24 | \ Explanatory material and minor reformatting (no code changes) by 25 | \ C. G. Montgomery March 2009, with helpful comments from David Williams 26 | \ and Krishna Myneni. 27 | 28 | \ Usage: 29 | 30 | \ The basic usage takes the form T{ -> }T . 31 | \ This executes and compares the resulting stack contents with 32 | \ the values, and reports any discrepancy between the 33 | \ two sets of values. 34 | \ For example: 35 | \ T{ 1 2 3 swap -> 1 3 2 }T ok 36 | \ T{ 1 2 3 swap -> 1 2 2 }T INCORRECT RESULT: T{ 1 2 3 swap -> 1 2 2 }T ok 37 | \ T{ 1 2 3 swap -> 1 2 }T WRONG NUMBER OF RESULTS: T{ 1 2 3 swap -> 1 2 }T ok 38 | 39 | \ Floating point testing can involve further complications. The code 40 | \ attempts to determine whether floating-point support is present, and 41 | \ if so, whether there is a separate floating-point stack, and behave 42 | \ accordingly. The CONSTANTs HAS-FLOATING and HAS-FLOATING-STACK 43 | \ contain the results of its efforts, so the behavior of the code can 44 | \ be modified by the user if necessary. 45 | 46 | \ Then there are the perennial issues of floating point value 47 | \ comparisons. Exact equality is specified by SET-EXACT (the 48 | \ default). If approximate equality tests are desired, execute 49 | \ SET-NEAR . Then the FVARIABLEs REL-NEAR (default 1E-12) and 50 | \ ABS-NEAR (default 0E) contain the values to be used in comparisons 51 | \ by the (internal) word FNEARLY= . 52 | 53 | \ When there is not a separate floating point stack and you want to 54 | \ use approximate equality for FP values, it is necessary to identify 55 | \ which stack items are floating point quantities. This can be done 56 | \ by replacing the closing }T with a version that specifies this, such 57 | \ as RRXR}T which identifies the stack picture ( r r x r ). The code 58 | \ provides such words for all combinations of R and X with up to four 59 | \ stack items. They can be used with either an integrated or separate 60 | \ floating point stacks. Adding more if you need them is 61 | \ straightforward; see the examples in the source. Here is an example 62 | \ which also illustrates controlling the precision of comparisons: 63 | 64 | \ SET-NEAR 65 | \ 1E-6 REL-NEAR F! 66 | \ T{ S" 3.14159E" >FLOAT -> -1E FACOS TRUE RX}T 67 | 68 | \ The word ERROR is now vectored, so that its action can be changed by 69 | \ the user (for example, to add a counter for the number of errors). 70 | \ The default action ERROR1 can be used as a factor in the display of 71 | \ error reports. 72 | 73 | \ Loading ttester.fs does not change BASE. Remember that floating point input 74 | \ is ambiguous if the base is not decimal. 75 | 76 | \ The file defines some 70 words in all, but in most cases only the 77 | \ ones mentioned above will be needed for successful testing. 78 | 79 | BASE @ 80 | DECIMAL 81 | 82 | VARIABLE ACTUAL-DEPTH \ stack record 83 | CREATE ACTUAL-RESULTS 32 CELLS ALLOT 84 | VARIABLE START-DEPTH 85 | VARIABLE XCURSOR \ for ...}T 86 | VARIABLE ERROR-XT 87 | 88 | : ERROR ERROR-XT @ EXECUTE ; \ for vectoring of error reporting 89 | 90 | : "FLOATING" S" FLOATING" ; \ only compiled S" in CORE 91 | : "FLOATING-STACK" S" FLOATING-STACK" ; 92 | "FLOATING" ENVIRONMENT? [IF] 93 | [IF] 94 | TRUE 95 | [ELSE] 96 | FALSE 97 | [THEN] 98 | [ELSE] 99 | FALSE 100 | [THEN] CONSTANT HAS-FLOATING 101 | "FLOATING-STACK" ENVIRONMENT? [IF] 102 | [IF] 103 | TRUE 104 | [ELSE] 105 | FALSE 106 | [THEN] 107 | [ELSE] \ We don't know whether the FP stack is separate. 108 | HAS-FLOATING \ If we have FLOATING, we assume it is. 109 | [THEN] CONSTANT HAS-FLOATING-STACK 110 | 111 | HAS-FLOATING [IF] 112 | \ Set the following to the relative and absolute tolerances you 113 | \ want for approximate float equality, to be used with F~ in 114 | \ FNEARLY=. Keep the signs, because F~ needs them. 115 | FVARIABLE REL-NEAR 1E-12 REL-NEAR F! 116 | FVARIABLE ABS-NEAR 0E ABS-NEAR F! 117 | 118 | \ When EXACT? is TRUE, }F uses FEXACTLY=, otherwise FNEARLY=. 119 | 120 | TRUE VALUE EXACT? 121 | : SET-EXACT ( -- ) TRUE TO EXACT? ; 122 | : SET-NEAR ( -- ) FALSE TO EXACT? ; 123 | 124 | : FEXACTLY= ( F: X Y -- S: FLAG ) 125 | ( 126 | Leave TRUE if the two floats are identical. 127 | ) 128 | 0E F~ ; 129 | 130 | : FABS= ( F: X Y -- S: FLAG ) 131 | ( 132 | Leave TRUE if the two floats are equal within the tolerance 133 | stored in ABS-NEAR. 134 | ) 135 | ABS-NEAR F@ F~ ; 136 | 137 | : FREL= ( F: X Y -- S: FLAG ) 138 | ( 139 | Leave TRUE if the two floats are relatively equal based on the 140 | tolerance stored in ABS-NEAR. 141 | ) 142 | REL-NEAR F@ FNEGATE F~ ; 143 | 144 | : F2DUP FOVER FOVER ; 145 | : F2DROP FDROP FDROP ; 146 | 147 | : FNEARLY= ( F: X Y -- S: FLAG ) 148 | ( 149 | Leave TRUE if the two floats are nearly equal. This is a 150 | refinement of Dirk Zoller's FEQ to also allow X = Y, including 151 | both zero, or to allow approximately equality when X and Y are too 152 | small to satisfy the relative approximation mode in the F~ 153 | specification. 154 | ) 155 | F2DUP FEXACTLY= IF F2DROP TRUE EXIT THEN 156 | F2DUP FREL= IF F2DROP TRUE EXIT THEN 157 | FABS= ; 158 | 159 | : FCONF= ( R1 R2 -- F ) 160 | EXACT? IF 161 | FEXACTLY= 162 | ELSE 163 | FNEARLY= 164 | THEN ; 165 | [THEN] 166 | 167 | HAS-FLOATING-STACK [IF] 168 | VARIABLE ACTUAL-FDEPTH 169 | CREATE ACTUAL-FRESULTS 32 FLOATS ALLOT 170 | VARIABLE START-FDEPTH 171 | VARIABLE FCURSOR 172 | 173 | : EMPTY-FSTACK ( ... -- ... ) 174 | FDEPTH START-FDEPTH @ < IF 175 | FDEPTH START-FDEPTH @ SWAP DO 0E LOOP 176 | THEN 177 | FDEPTH START-FDEPTH @ > IF 178 | FDEPTH START-FDEPTH @ DO FDROP LOOP 179 | THEN ; 180 | 181 | : F{ ( -- ) 182 | FDEPTH START-FDEPTH ! 0 FCURSOR ! ; 183 | 184 | : F-> ( ... -- ... ) 185 | FDEPTH DUP ACTUAL-FDEPTH ! 186 | START-FDEPTH @ > IF 187 | FDEPTH START-FDEPTH @ - 0 DO ACTUAL-FRESULTS I FLOATS + F! LOOP 188 | THEN ; 189 | 190 | : F} ( ... -- ... ) 191 | FDEPTH ACTUAL-FDEPTH @ = IF 192 | FDEPTH START-FDEPTH @ > IF 193 | FDEPTH START-FDEPTH @ - 0 DO 194 | ACTUAL-FRESULTS I FLOATS + F@ FCONF= INVERT IF 195 | S" INCORRECT FP RESULT: " ERROR LEAVE 196 | THEN 197 | LOOP 198 | THEN 199 | ELSE 200 | S" WRONG NUMBER OF FP RESULTS: " ERROR 201 | THEN ; 202 | 203 | : F...}T ( -- ) 204 | FCURSOR @ START-FDEPTH @ + ACTUAL-FDEPTH @ <> IF 205 | S" NUMBER OF FLOAT RESULTS BEFORE '->' DOES NOT MATCH ...}T SPECIFICATION: " ERROR 206 | ELSE FDEPTH START-FDEPTH @ = 0= IF 207 | S" NUMBER OF FLOAT RESULTS BEFORE AND AFTER '->' DOES NOT MATCH: " ERROR 208 | THEN THEN ; 209 | 210 | 211 | : FTESTER ( R -- ) 212 | FDEPTH 0= ACTUAL-FDEPTH @ FCURSOR @ START-FDEPTH @ + 1+ < OR IF 213 | S" NUMBER OF FLOAT RESULTS AFTER '->' BELOW ...}T SPECIFICATION: " ERROR 214 | ELSE ACTUAL-FRESULTS FCURSOR @ FLOATS + F@ FCONF= 0= IF 215 | S" INCORRECT FP RESULT: " ERROR 216 | THEN THEN 217 | 1 FCURSOR +! ; 218 | 219 | [ELSE] 220 | : EMPTY-FSTACK ; 221 | : F{ ; 222 | : F-> ; 223 | : F} ; 224 | : F...}T ; 225 | 226 | HAS-FLOATING [IF] 227 | : COMPUTE-CELLS-PER-FP ( -- U ) 228 | DEPTH 0E DEPTH 1- >R FDROP R> SWAP - ; 229 | 230 | COMPUTE-CELLS-PER-FP CONSTANT CELLS-PER-FP 231 | 232 | : FTESTER ( R -- ) 233 | DEPTH CELLS-PER-FP < ACTUAL-DEPTH @ XCURSOR @ START-DEPTH @ + CELLS-PER-FP + < OR IF 234 | S" NUMBER OF RESULTS AFTER '->' BELOW ...}T SPECIFICATION: " ERROR EXIT 235 | ELSE ACTUAL-RESULTS XCURSOR @ CELLS + F@ FCONF= 0= IF 236 | S" INCORRECT FP RESULT: " ERROR 237 | THEN THEN 238 | CELLS-PER-FP XCURSOR +! ; 239 | [THEN] 240 | [THEN] 241 | 242 | : EMPTY-STACK \ ( ... -- ) empty stack; handles underflowed stack too. 243 | DEPTH START-DEPTH @ < IF 244 | DEPTH START-DEPTH @ SWAP DO 0 LOOP 245 | THEN 246 | DEPTH START-DEPTH @ > IF 247 | DEPTH START-DEPTH @ DO DROP LOOP 248 | THEN 249 | EMPTY-FSTACK ; 250 | 251 | : ERROR1 \ ( C-ADDR U -- ) display an error message 252 | \ followed by the line that had the error. 253 | TYPE SOURCE TYPE CR \ display line corresponding to error 254 | EMPTY-STACK \ throw away everything else 255 | ; 256 | 257 | ' ERROR1 ERROR-XT ! 258 | 259 | : T{ \ ( -- ) syntactic sugar. 260 | DEPTH START-DEPTH ! 0 XCURSOR ! F{ ; 261 | 262 | : -> \ ( ... -- ) record depth and contents of stack. 263 | DEPTH DUP ACTUAL-DEPTH ! \ record depth 264 | START-DEPTH @ > IF \ if there is something on the stack 265 | DEPTH START-DEPTH @ - 0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ save them 266 | THEN 267 | F-> ; 268 | 269 | : }T \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED 270 | \ (ACTUAL) CONTENTS. 271 | DEPTH ACTUAL-DEPTH @ = IF \ if depths match 272 | DEPTH START-DEPTH @ > IF \ if there is something on the stack 273 | DEPTH START-DEPTH @ - 0 DO \ for each stack item 274 | ACTUAL-RESULTS I CELLS + @ \ compare actual with expected 275 | <> IF S" INCORRECT RESULT: " ERROR LEAVE THEN 276 | LOOP 277 | THEN 278 | ELSE \ depth mismatch 279 | S" WRONG NUMBER OF RESULTS: " ERROR 280 | THEN 281 | F} ; 282 | 283 | : ...}T ( -- ) 284 | XCURSOR @ START-DEPTH @ + ACTUAL-DEPTH @ <> IF 285 | S" NUMBER OF CELL RESULTS BEFORE '->' DOES NOT MATCH ...}T SPECIFICATION: " ERROR 286 | ELSE DEPTH START-DEPTH @ = 0= IF 287 | S" NUMBER OF CELL RESULTS BEFORE AND AFTER '->' DOES NOT MATCH: " ERROR 288 | THEN THEN 289 | F...}T ; 290 | 291 | : XTESTER ( X -- ) 292 | DEPTH 0= ACTUAL-DEPTH @ XCURSOR @ START-DEPTH @ + 1+ < OR IF 293 | S" NUMBER OF CELL RESULTS AFTER '->' BELOW ...}T SPECIFICATION: " ERROR EXIT 294 | ELSE ACTUAL-RESULTS XCURSOR @ CELLS + @ <> IF 295 | S" INCORRECT CELL RESULT: " ERROR 296 | THEN THEN 297 | 1 XCURSOR +! ; 298 | 299 | : X}T XTESTER ...}T ; 300 | : XX}T XTESTER XTESTER ...}T ; 301 | : XXX}T XTESTER XTESTER XTESTER ...}T ; 302 | : XXXX}T XTESTER XTESTER XTESTER XTESTER ...}T ; 303 | 304 | HAS-FLOATING [IF] 305 | : R}T FTESTER ...}T ; 306 | : XR}T FTESTER XTESTER ...}T ; 307 | : RX}T XTESTER FTESTER ...}T ; 308 | : RR}T FTESTER FTESTER ...}T ; 309 | : XXR}T FTESTER XTESTER XTESTER ...}T ; 310 | : XRX}T XTESTER FTESTER XTESTER ...}T ; 311 | : XRR}T FTESTER FTESTER XTESTER ...}T ; 312 | : RXX}T XTESTER XTESTER FTESTER ...}T ; 313 | : RXR}T FTESTER XTESTER FTESTER ...}T ; 314 | : RRX}T XTESTER FTESTER FTESTER ...}T ; 315 | : RRR}T FTESTER FTESTER FTESTER ...}T ; 316 | : XXXR}T FTESTER XTESTER XTESTER XTESTER ...}T ; 317 | : XXRX}T XTESTER FTESTER XTESTER XTESTER ...}T ; 318 | : XXRR}T FTESTER FTESTER XTESTER XTESTER ...}T ; 319 | : XRXX}T XTESTER XTESTER FTESTER XTESTER ...}T ; 320 | : XRXR}T FTESTER XTESTER FTESTER XTESTER ...}T ; 321 | : XRRX}T XTESTER FTESTER FTESTER XTESTER ...}T ; 322 | : XRRR}T FTESTER FTESTER FTESTER XTESTER ...}T ; 323 | : RXXX}T XTESTER XTESTER XTESTER FTESTER ...}T ; 324 | : RXXR}T FTESTER XTESTER XTESTER FTESTER ...}T ; 325 | : RXRX}T XTESTER FTESTER XTESTER FTESTER ...}T ; 326 | : RXRR}T FTESTER FTESTER XTESTER FTESTER ...}T ; 327 | : RRXX}T XTESTER XTESTER FTESTER FTESTER ...}T ; 328 | : RRXR}T FTESTER XTESTER FTESTER FTESTER ...}T ; 329 | : RRRX}T XTESTER FTESTER FTESTER FTESTER ...}T ; 330 | : RRRR}T FTESTER FTESTER FTESTER FTESTER ...}T ; 331 | [THEN] 332 | 333 | \ Set the following flag to TRUE for more verbose output; this may 334 | \ allow you to tell which test caused your system to hang. 335 | VARIABLE VERBOSE 336 | FALSE VERBOSE ! 337 | 338 | : TESTING \ ( -- ) TALKING COMMENT. 339 | SOURCE VERBOSE @ 340 | IF DUP >R TYPE CR R> >IN ! 341 | ELSE >IN ! DROP 342 | THEN ; 343 | 344 | BASE ! 345 | \ end of ttester.fs -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # tape-recorder 2 | 3 | What if we make it simple, easy and inexpensive to do the right thing? Tape Recorder makes it simple and easy to use Bitcoin to record everyday activities. 4 | 5 | What if you could ... 6 | 1) Run your Bitcoin application on your computer or device ... 7 | 2) And a recording of the execution could be saved onto a "tape" ... 8 | 3) Then the tape could be stored onto the BSV blockchain, not as data, but as Bitcoin Script? 9 | 10 | Tape Recorder does exactly that. It is a Wang B Machine. It records execution as it runs your application and stores it onto a "tape". (A tape is simply a list of computer instructions, also called a thread of execution, that is stored as Bitcoin bytecode in hex format). 11 | 12 | Tape Recorder allows for full attestation of what was executed on your computer. It is Proof of execution of the most minute detail, data and code. 13 | If it is easy and inexpensive to record attestations then people will probably do it. If it is difficult and expensive then they probably wont use Bitcoin. 14 | 15 | Tape Recorder makes it simple and unobtrusive to store data, important events and significantly, code execution onto the blockchain. Fully attestable. 16 | 17 | Tape Recorder is an individual, personal experience. It involves your device, Tape Recorder and the blockchain. (There is no world computer!) Users will have privacy settings for Tape Recorder. Users will be able to choose which events and processing they wish to capture, whether to make the information public or private and when to disclose the data downstream. When the user's role is that of an employee or public official then all of the privacy policies can be determined in an employment contract. 18 | 19 | Imagine billions of people with a means to easily record their application's execution onto the blockchain. Large blocks will contain lots of Bitcoin Script as well as data. Script execution will be hyper-optimized. 20 | 21 | Bitcoin scales because it is simple and efficient. Bitcoin Script bytecode is compact. 22 | 23 | # When would Tape Recorder be used? 24 | 25 | Tape Recorder can conceviably record the execution of any application that is built upon the Bitcoin opcode primitives. Since Bitcoin is Turing complete any application could be built on Bitcoin and once executed the tape recording can be stored onchain. Not once. Each and every time it gets executed. 26 | 27 | In general, major use cases for Tape Recorder would be centered around performance contracts. Whenever you are subject to specific performance, bound by a performance contract to perform specific duties, you can attest to your performance by recording the activity. It could be specific performance required under an employment contract or any private contract. 28 | 29 | Not all contracts are explicit. And users may wish to capture other computations and activities even when not bound by a contract. 30 | 31 | Script attestations promote transparency. 32 | 33 | One example would be an election official performing their duty when counting votes. They would start recording. As their computer counts the votes all the instructions are being recorded as bytecode using Tape Recorder. Invalid ballots are accounted for. Data is grouped and summarized. The recording stops and the code is put on chain as Bitcoin Script. Anyone can validate the vote count by executing the published script. 34 | 35 | Scientific data that needs to be crunched and attested to is another area. 36 | 37 | Tape Recorder could be used any time detail data is filtered, processed, grouped or summarized. Capturing the execution path between the data points is key. 38 | 39 | Writing applications that are fully attestable is difficult, but Tape Recorder shows that it is possible. 40 | 41 | # Tape Recorder Attestations 42 | 43 | Tape Recorder code has this basic structure. Lets call them attestations. 44 | ``` 45 | recorder-on recorder-off 46 | ``` 47 | The code can be any bitcoin script or something that compiles to bitcoin script. Instructions that are necessary for attestation between the on/off get recorded. 48 | 49 | For example, the following attestation computes factorial of 5. It loops inside the `fac` function. 50 | ``` 51 | recorder-on 5 fac 120 PUSHDATA OP_EQUAL recorder-off 52 | ``` 53 | During execution the loop is unrolled when it is written to tape. The tape looks like this (in ASM format). 54 | ``` 55 | 01 01 OP_MUL 02 OP_MUL 03 OP_MUL 04 OP_MUL 05 OP_MUL 78 OP_EQUAL 56 | ``` 57 | The tape looks like this (Hex format) when it goes on chain. 58 | ``` 59 | 0101010195010295010395010495010595017887 60 | ``` 61 | 62 | # Why Bitcoin Script? 63 | Storing data on the blockchain is good. 64 | Storing data within executable script is better. 65 | 66 | Using a single data stream that includes data within script allows for data validation rules to be passed in script. Bitcoin opcodes are single bytes, very compact and efficient to interpret. They are ideally suited for this purpose. 67 | 68 | 1) Storing only your application's data means that you are sampling your application state. But what happened in between states? If you can capture the execution of your application then you are effectively showing every state of your application. Tape Recorder captures this thread of execution as your application travels between states. It is full attestation. 69 | 70 | 2) Data could be stored that is logically inconsistent since a miner does not "execute" data. A miner executes code and interprets Bitcoin Script. Supplying code to validate the data means that the data was interpreted by a miner during validation. 71 | 72 | (Invalid script seems to make the Bitcoin burnt and ends the thread of execution. More investigation needs to be done on properly validating the script. One possibility is to do additional validation in Tape Recorder, the higher layers of the application, to prevent the possibility of coin burn.) 73 | 74 | # Why Forth? 75 | Tape Recorder is written in Forth. 76 | 77 | Forth is very similar to Bitcoin Script. There is very little code to write when translating an application between bitcoin script and Forth. 78 | 79 | Here is an example translation. `OP_DUP` is the bitcoin instruction. `dup` is the Forth word. 0x76 is the bitcoin bytecode. 80 | ``` 81 | : OP_DUP dup 0x76 write ; 82 | ``` 83 | This code tells Forth that when it sees `OP_DUP` it should execute `dup` and write 76 hex to the tape. Simple. 84 | 85 | Once all the necessary Bitcoin opcode primitives were implemented in Forth then it becomes possible to write high level code that executes to bitcoin bytecode. (Not compiles, executes. It is a Wang B machine) 86 | 87 | Here is the high level Forth code that loops while calculating Factorial. 88 | 89 | ``` 90 | : fac ( top of stack is the number of iterations to run ) 91 | 1 PUSHDATA 92 | swap 1+ 1 93 | ?do 94 | i PUSHDATA OP_MUL 95 | loop ; 96 | ``` 97 | When Tape Recorder executes the high level Forth code it produces unrolled Bitcoin script bytecode. Here is the output of running `5 fac`. 98 | ``` 99 | 01 01 OP_MUL 02 OP_MUL 03 OP_MUL 04 OP_MUL 05 OP_MUL 100 | ``` 101 | 102 | The main Forth file is taperecorder.fs. 103 | The Forth to Bitcoin bycode transaction is done in bitcoin.fs. 104 | 105 | # Broadcasting attestations 106 | 107 | The code to interact with the BSV blockchain was written in JavaScript using the bsv library. It takes the output tape (tape.txt) of Tape Recorder and stores it onchain in a Metanet transaction. See broadcaster.js. 108 | 109 | # What if you hate Forth? And hate Bitcoin Script? How about Hello? 110 | [BSV Editor](http://www.bowmain.co.uk/BSV/index.html) will compile a high level C-like language called Hello to Bitcoin script. 111 | Tape Recorder can execute the script that BSV Editor produces. 112 | Here is an example of looping in Hello. 113 | ``` 114 | cnt = 0x02; 115 | for i in [1 .. 2] 116 | { 117 | cnt = cnt + i; 118 | } 119 | ``` 120 | The compiled code for this program is in hack.hll.script. I had to make some small insignificant edits to the script file to make it run in Tape Recorder. The Tape Recorder executable code is in hack.fs. 121 | 122 | There are many other possibilities for high level languages that could be executed by Tape Recorder to increase developer productivity. 123 | 124 | # A Tape Recorder payment channel 125 | 126 | Another possibility is to run Tape Recorder as a service. Users would submit requests to be run by Tape Recorder using the Bitcoin protocol. Of course the payment channel version of Tape Recorder could be run as a direct IP2IP channel using the techniques in [Ubiquity](https://github.com/dfoderick/ubiquity-hackathon). 127 | 128 | # Layer 1 vs Layer 2 129 | 130 | Bitcoin is a layered architecture. 131 | 132 | Layer 1 Bitcoin is the base protocol as enforced by miner nodes. 133 | Layer 2 is your Bitcoin application running off chain on your computer. 134 | 135 | The Bitcoin protocol at its most basic level is simply data within script. Because the bitcoin protocol is valuable, it is to be used off chain in your Layer 2 application. Consequently, users execute script in Layer 2 of Bitcoin on their own CPU. Tape Recorder captures these threads of execution while interpreting your bitcoin application in Layer 2 and stores them on chain. 136 | 137 | # Tape Recorder is a Wang B machine 138 | 139 | A Wang B machine is a simplified Turing machine. 140 | It has a Jump instruction so it can loop. It does not have an erase instruction. 141 | 142 | A Wang B machine has a two-way tape. One side is for reading. The other side is for writing. 143 | The read side is for executing (interpreting) a program. As it reads instructions it writes them to the write side of the tape. The write side of the tape is append only, non-erasable. It is a recorder. It records computer instructions. 144 | 145 | Tape Recorder interprets and executes your Layer 2 application as the read side of the tape. Your application can loop. As it executes your app, Tape Recorder records the instructions onto the write side of the append-only tape. Thus, the loop is unrolled. Loop unrolling happens during runtime of the application, not at compile time. 146 | Consequently, your application can loop but the miner only sees an unrolled loop. Therefore, a miner need not loop to execute and validate the execution of your loopy code. 147 | 148 | # Metanet and Tape Recorder 149 | In Layer 1, bitcoin transactions are chained together using digital signatures with scriptSig and scriptPubKey. 150 | Metanet (the technical protocol spec) is an overlay structure for Layer 2 applications. 151 | 152 | Tape Recorder is a Layer 2 application that fundamentally stores threads of execution as Bitcoin Script. It should leverage the Metanet protocol as much as possible since there is a lot of good tooling for Metanet but the primary motive is to preserve the continuity of the thread of execution. 153 | 154 | Some ideas ... 155 | Transaction Output 0 would be a Metanet OP_RETURN with metadata (attributes) describing the script thread (Who, When and Why the thread was executed, i.e. the thread context). Any extra information that can be stored to aid in attestation. 156 | Transaction Output 1 would be the primary thread of execution. i.e. the script. i.e. the tape. 157 | The thread of execution could continue in the same transaction in outputs 2, 3, etc but what advantage would that have? Maybe to show iterations in the case of looping? Attestation of counter variables? Logical grouping? 158 | 159 | The overriding principle is that the thread should be in a spendable utxo so a paused thread of execution can be resumed by the thread owner. Threads of execution can be paused and resumed since the utxo should have the full state of the executing thread. 160 | 161 | When the Layer 2 tape is chained across transactions the tape is "spliced" together, either by Layer 1 digital signatures or by Metanet Layer 2 signatures and pub keys. 162 | 163 | # Notes 164 | 165 | All hackathon related files are in the hackathon folder. 166 | 167 | # Sample Forth code 168 | Samples can be found in testrecorder.fs 169 | 170 | testadd - adds two numbers 171 | testfac - computes factorial 172 | testsqrt - computes square root 173 | testgcd - computes greatest common divisor 174 | testhack - loops using high level language Hello from BSV Editor 175 | 176 | # Installing Tape Recorder 177 | 1) Clone the repo 178 | ``` 179 | git clone https://github.com/dfoderick/tape-recorder.git 180 | ``` 181 | 2) Install gforth 182 | ``` 183 | sudo apt install gforth 184 | ``` 185 | 3) Install node and npm 186 | ``` 187 | sudo apt-get install nodejs 188 | sudo apt install npm 189 | ``` 190 | 4) Install js packages 191 | ``` 192 | cd ~/tape-recorder 193 | npm install 194 | ``` 195 | 5) Tape Recorder broadcaster will error if tape.txt does not exist so create empty tape 196 | ``` 197 | touch ~/tape-recorder/hackathon/app/tape.txt 198 | ``` 199 | 200 | # Running Tape Recorder 201 | 202 | A video walkthrough for Tape Recorder is at 203 | https://www.youtube.com/watch?v=xV2RYQ1cTEU&t=3s 204 | 205 | 1) run Tape Recorder broadcaster 206 | ``` 207 | cd ~/tape-recorder/hackathon/js 208 | node broadcaster auto 209 | ``` 210 | Your console should say `Waiting for changes ...` 211 | 212 | 2) run Tape Recorder 213 | ``` 214 | cd ~/tape-recorder/hackathon/app 215 | gforth 216 | ``` 217 | gforth console will be open. Load Tape Recorder and tests. 218 | ``` 219 | include taperecorder.fs 220 | include testrecorder.fs 221 | ``` 222 | 223 | # Tape Recorder Walkthrough 224 | Run any of the test commands `testadd`, `testfac`, `testsqrt`, `testgcd`, `testhack` 225 | Tape Recorder console should respond with `-1 ok` indicating success since -1 in Forth means `true`. 226 | 227 | As you run the tests the broadcaster console will show you the tx ids that are getting stored on the blockchain. There may be a slight delay because the node file watcher polls for changes every 5 seconds or so. 228 | 229 | You can view the transactions and the script in any BSV testnet explorer. 230 | 231 | Now go ahead and experiment. Forth is a concatenative language. Parameters are passed in the data stack. A Forth function is called a word. A series of Forth words is called a thread. 232 | If you want to see the definition of any Forth word use `see` 233 | ``` 234 | see testfac 235 | see fac 236 | ``` 237 | 238 | The general structure of a Tape Recorder program looks like this: 239 | ``` 240 | ron roff . 241 | ``` 242 | Commands can be concatenated. 243 | ``` 244 | ron 4 fac op_1 op_add sqrt roff . 245 | ``` 246 | 4! is 24. Then add 1. Then calculate the square root. The result is 5. 247 | 248 | # TODO 249 | The following are works in progress 250 | * broadcaster.js should write the transaction as a Metanet transaction 251 | * implement all the Bitcoin opcodes. Many are sill commented out in bitcoin.fs 252 | * the interaction between Tape Recorder (Forth) and broadcaster (js) could be improved. Can broadcaster be implemented in Forth? 253 | * Implement a payment channel version of Tape Recorder 254 | * Investigate Webassembly version of bitcoin script interpreter 255 | * Investigate interpreter for mobile devices and IOT 256 | * More apps and use cases 257 | 258 | Dave Foderick 259 | dfoderick@gmail.com 260 | 261 | -------------------------------------------------------------------------------- /src/app/lib/big.4th: -------------------------------------------------------------------------------- 1 | \ -----file big.4th begins------ 2 | 3 | \ Arithmetic on big signed-magnitude numbers. 4 | 5 | \ Forth Scientific Library Algorithm #47 6 | 7 | \ Copyright 1996 by Leonard Francis Zettel, Jr. 8 | \ Released to the Forth Scientific Library. 9 | \ This file may be compiled, copied, modified, or sold provided: 10 | \ 1) Full liability for any consequences of doing so is taken. 11 | \ 2) The nature of any modifications is clearly indicated. 12 | 13 | \ This is an ANS Forth program requiring: 14 | \ 0<> <> FALSE NIP TRUE \ From the Core Extension word set 15 | \ 2CONSTANT D< M+ From the Double-Number word set 16 | \ ? From the Programming-Tools word set 17 | \ [IF] [ELSE] [THEN] from the Programming-Tools Extension word set 18 | \ (conditional compilation used only for setting biggest) 19 | 20 | \ This is a Forth implementation of the "classical algorithms". 21 | \ See Knuth, Donald The Art of Computer Programming Vol 2 p 250. 22 | 23 | \ The internal representation of the big numbers is "little-endian 24 | \ signed magnitude". The cell at the address addr contains n, the 25 | \ size of the number in digits. n is positive for positive numbers, 26 | \ negative for negative. Each succeeding cell contains a digit of 27 | \ the number in base 2**(cell size-1), least significant digit first. 28 | 29 | BASE @ DECIMAL \ Housekeeping 30 | 31 | CREATE MAX-N CHAR M C, CHAR A C, CHAR X C, CHAR - C, CHAR N C, 32 | \ Yes, this is clumsy, but it avoids making it necessary to specify 33 | \ the use of S" from the File word set. 34 | 35 | MAX-N 5 ENVIRONMENT? [IF] [ELSE] 32767 [THEN] 36 | 37 | CONSTANT biggest \ Largest representable signed number 38 | 39 | biggest 1+ CONSTANT bigbase \ big number base as an unsigned number 40 | 41 | biggest S>D 1 M+ 2CONSTANT bigbd \ big number base as a double number 42 | 43 | : cell- ( addr1 -- addr2) \ addr2 is the cell address below addr1 44 | 1 CELLS - ; 45 | 46 | \ This code guided by the description of DIGIT in C. H. Ting, F-PC 47 | \ Technical Reference Manual, 2nd ed. Offete Enterprises 1989 p. 82. 48 | 49 | \ DIGIT is intended for the character range specified by the standard (0..Z) 50 | \ Lower-case digit conversion will require system-specific code modification. 51 | 52 | : DIGIT ( c n1 -- n2 true | false) \ attempt to convert c to its 53 | \ numerical value in base n1. Return the value and TRUE if 54 | \ successful, FALSE otherwise. 55 | OVER [CHAR] 0 < 56 | IF 2DROP FALSE \ characters below the zero character 57 | \ can't be digits 58 | ELSE OVER [CHAR] : < 59 | IF DROP [CHAR] 0 - TRUE 60 | ELSE OVER [CHAR] A < 61 | IF 2DROP FALSE 62 | ELSE SWAP [CHAR] 7 - \ convert to numeric value 63 | DUP ROT < 64 | IF TRUE \ valid digit 65 | ELSE DROP FALSE 66 | THEN 67 | THEN 68 | THEN 69 | THEN ; 70 | 71 | \ Words to handle spillover between cells during calculations 72 | 73 | : carry ( digit -- carry digit) \ check for a carry, remove it, leave it 74 | \ under the result. 75 | biggest OVER U< 76 | IF bigbase - \ Remove the carry 77 | 1 \ Show we had a carry 78 | ELSE 0 \ show we had no carry 79 | THEN SWAP ; 80 | 81 | : D>carry ( low high -- carry digit) \ convert a double number to a 82 | \ low-order digit and a carry. 83 | bigbase UM/MOD SWAP ; 84 | 85 | : overflow? ( borrow uj -- uj new_borrow) \ If uj is negative (indicating 86 | \ a result out of range on the previous subtraction), bring it in 87 | \ range and increment the borrow that will be necessary on the next 88 | \ digit. 89 | DUP 0< IF bigbase + 1 ELSE 0 THEN 90 | ROT + ; 91 | 92 | \ Words to point to parts of big numbers 93 | 94 | : big_digit_pointer ( --) ( n -- address) \ create a word . 95 | \ when is executed return the address of the nth cell after 96 | \ the address in 's data field. 97 | CREATE 1 CELLS ALLOT \ create the word & allot the data space 98 | DOES> @ \ put the address in 's data field 99 | \ on the stack 100 | SWAP CELLS + ; \ Increment the address by index cells 101 | 102 | : to_pointer ( -- addr1) \ compiling: addr1 is 's data field. 103 | ( addr2 --) \ execution: addr2 is placed in 's 104 | \ data field. 105 | ' >BODY POSTPONE LITERAL POSTPONE ! ; IMMEDIATE 106 | 107 | 108 | \ Miscellaneous operations on big numbers 109 | 110 | big_digit_pointer clippee 111 | 112 | : clip ( addr --) \ remove leading zeroes from the number at addr 113 | to_pointer clippee 114 | 0 \ default - no non-zero digits 115 | 1 0 clippee @ ABS \ loop from present number of digits to one. 116 | DO I clippee @ \ next big digit 117 | 0<> IF DROP I LEAVE THEN \ index of first non-zero digit 118 | \ on stack 119 | -1 +LOOP 120 | ?DUP IF 0 clippee @ \ original sign & size 121 | 0< IF NEGATE THEN \ minus sign on new size 122 | ELSE 1 \ number is exactly zero, keep one 123 | \ of the zeros, show plus number 124 | THEN 125 | 0 clippee ! ; \ store new size 126 | 127 | 128 | : big_digit ( addr n1 -- n2) \ Return digit n1 of the big number at addr. 129 | \ If n1 is greater than the number of digits, return a leading zero. 130 | OVER @ ABS \ number of digits 131 | OVER < 132 | IF 2DROP 0 \ Return leading zero 133 | ELSE CELLS + @ \ Return digit 134 | THEN ; 135 | 136 | : bignegate ( addr --) \ Change the sign of the big number at addr 137 | DUP @ DUP \ Number of digits 138 | 1 = IF OVER CELL+ @ \ Check for zero 139 | IF NEGATE SWAP ! \ Non-zero, negate 140 | ELSE 2DROP \ Zero, do nothing 141 | THEN 142 | ELSE NEGATE SWAP ! 143 | THEN ; 144 | 145 | : bigabs ( addr --) \ Give the big number at addr its absolute value, 146 | DUP @ ABS SWAP ! ; 147 | 148 | : big>here ( addr --) \ "big to here" append the big number at addr 149 | \ to the end of data space. 150 | HERE \ address to move to 151 | OVER @ ABS 1+ CELLS \ Number of address units in the number 152 | DUP ALLOT \ allot space for the number 153 | MOVE ; 154 | 155 | 156 | : adjust_sign ( addr1 addr2 addr3 -- addr3) \ adjust the sign of the big 157 | \ number at addr3 according to the rules for forming the algebraic 158 | \ product from the operands at addr1 and addr2 159 | ROT @ ROT @ XOR 0< IF DUP bignegate THEN ; 160 | 161 | \ Move the number at addr1 to addr2 and free any data space beyond it. 162 | : reposition ( addr1 addr2 -- ) 163 | SWAP 2DUP @ \ (addr2 addr1 addr2 size) 164 | ABS 1+ CELLS \ (addr2 addr1 addr2 bytes) 165 | DUP >R MOVE \ (addr2) (bytes) 166 | R> + HERE - ALLOT ; 167 | 168 | 169 | \ Comparison operators 170 | 171 | big_digit_pointer |big|1 big_digit_pointer |big|2 172 | 173 | : |big|= ( addr1 addr2 -- flag) \ TRUE if the big number at addr1 has the 174 | \ same absolute value as the big number at addr2. FALSE otherwise 175 | OVER @ ABS OVER @ ABS = \ are the numbers the same size? 176 | IF to_pointer |big|1 177 | to_pointer |big|2 178 | TRUE \ default initial flag. 179 | 1 0 |big|1 @ ABS 180 | DO I |big|1 @ 181 | I |big|2 @ <> 182 | IF DROP FALSE LEAVE THEN 183 | -1 184 | +LOOP 185 | ELSE 2DROP FALSE 186 | THEN ; 187 | 188 | 189 | : |big|< ( addr1 addr2 -- flag) \ TRUE if the absolute value of the 190 | \ big number at addr1 is less than the absolute value of the big number 191 | \ at addr2. FALSE otherwise. 192 | 193 | to_pointer |big|2 194 | to_pointer |big|1 195 | 0 |big|1 @ ABS 196 | 0 |big|2 @ ABS 197 | 2DUP < 198 | IF 2DROP TRUE 199 | ELSE = FALSE \ default flag if equal, result if <>. 200 | SWAP 201 | IF 1 0 |big|1 @ ABS \ From the high order digit to the first 202 | DO \ digit 203 | I |big|1 @ 204 | I |big|2 @ 205 | 2DUP 206 | <> IF < NIP LEAVE THEN 207 | 2DROP 208 | -1 +LOOP 209 | THEN 210 | THEN ; 211 | 212 | 213 | : big0= ( addr -- flag) \ Return TRUE if the big number at addr is zero. 214 | DUP @ 1 = IF CELL+ @ 0= ELSE DROP FALSE THEN ; 215 | 216 | : big0<> ( addr -- flag) \ Return TRUE if the big number at addr is not zero. 217 | big0= 0= ; 218 | 219 | : big0< ( addr -- flag) @ 0< ; 220 | 221 | : big< ( addr1 addr2 -- flag) \ TRUE if the operand at addr1 is less than 222 | \ the operand at addr2. FALSE otherwise. 223 | OVER @ OVER @ < \ Look at operand sign & number of digits 224 | IF 2DROP TRUE 225 | ELSE \ ( addr1 addr2) 226 | OVER @ OVER @ > 227 | IF 2DROP FALSE 228 | ELSE \ To get here the operands must be the 229 | \ same sign & be of equal length 230 | DUP @ 0< 231 | IF SWAP THEN \ If the numbers are negative, the one with 232 | \ the larger absolute value is the lesser. 233 | DUP @ ABS >R \ Park number of digits 234 | R@ CELLS 235 | DUP ROT + \ High order cell of operand 2. 236 | ROT ROT + \ High order cell of operand 1. 237 | SWAP 238 | FALSE \ dummy initial flag 239 | R> 0 240 | DO \ ( addr1 addr2 flag) 241 | DROP \ flag from previous cycle 242 | OVER @ OVER @ \ ( addr1 addr2 digit1 digit2) 243 | < DUP IF LEAVE THEN 244 | ROT cell- ROT cell- 245 | ROT 246 | LOOP 247 | NIP NIP 248 | THEN 249 | THEN 250 | ; 251 | 252 | : big= ( addr1 addr2 -- flag) \ TRUE if the big number at addr1 has the 253 | \ same absolute value as the big number at addr2. FALSE otherwise 254 | OVER @ OVER @ = \ are the numbers the same size? 255 | IF to_pointer |big|1 256 | to_pointer |big|2 257 | TRUE \ default initial flag. 258 | 1 0 |big|1 @ ABS 259 | DO I |big|1 @ 260 | I |big|2 @ <> 261 | IF DROP FALSE LEAVE THEN 262 | -1 263 | +LOOP 264 | ELSE 2DROP FALSE 265 | THEN ; 266 | 267 | 268 | \ Words doing mixed single-precision and big number arithmetic 269 | 270 | big_digit_pointer big_addend 271 | 272 | : big+s ( addr n --) \ add n to the number at addr. n must be non-negative 273 | \ the number at addr must be non-negative and end at HERE. 274 | SWAP to_pointer big_addend \ ( n) 275 | 0 big_addend @ ABS 1+ \ loop limit 276 | 1 \ loop start 277 | DO \ ( n) 278 | I big_addend @ + \ ( ui+n) 279 | carry 280 | I big_addend ! \ store new ui 281 | DUP 0= IF LEAVE THEN \ no carry, we are done 282 | LOOP 283 | \ carry in high-order digit? 284 | IF 285 | 1 , \ append carry to the number 286 | 1 0 big_addend +! \ Increment number size 287 | THEN ; 288 | 289 | big_digit_pointer big_multiplicand 290 | 291 | : big*s ( addr n -- ) \ multiply the number at addr by n. 292 | \ n must be positive 293 | \ the number at addr must end at "here" 294 | SWAP 295 | to_pointer big_multiplicand 296 | 0 \ ( n carry) 297 | 0 big_multiplicand @ ABS 1+ 298 | 1 299 | DO \ ( n carry) 300 | OVER 301 | I big_multiplicand @ 302 | M* \ ( carry n low[ui*n] high[ui*n]) 303 | ROT M+ \ ( n low[ui*n+carry] high[ui*n+carry]) 304 | D>carry \ ( n carry ui*n) 305 | I big_multiplicand ! \ store digit i back in u ( n carry) 306 | LOOP 307 | NIP 308 | ?DUP IF 0 big_multiplicand @ \ ( carry n) 309 | DUP 0< IF 1- 310 | ELSE 1+ 311 | THEN \ ( carry n) 312 | 0 big_multiplicand ! , 313 | THEN ; 314 | 315 | 316 | big_digit_pointer big_dividend 317 | 318 | : big/mods ( addr n1 -- n2) \ "big slash-mod s". Divide the big number at 319 | \ addr by n1, leaving the quotient at addr. n2 is the remainder. 320 | SWAP 321 | to_pointer big_dividend 322 | 0 \ ( divisor remainder) 323 | 1 0 big_dividend @ ABS 324 | DO \ ( divisor remainder) 325 | bigbase UM* \ ( divisor lowr highr) 326 | I big_dividend @ \ ( divisor divisor lowr highr uj) 327 | M+ 328 | 2 PICK 329 | UM/MOD \ ( divisor r wj ) 330 | I big_dividend ! 331 | -1 332 | +LOOP 333 | NIP 0 big_dividend clip ; 334 | 335 | 336 | \ Words for going from characters to big numbers 337 | 338 | : >big_number ( addr1 addr2 u1 -- addr1 addr3 u2) \ "to big number" 339 | \ extend the big number at addr1 by the number represented by the 340 | \ string of u1 characters at addr2. addr3 is the address of the first 341 | \ unconverted character and u2 is the number of unconverted characters 342 | 2DUP + >R \ address just beyond end of string on 343 | \ return stack 344 | 0 DO \ ( addr1 addr2) 345 | 2DUP C@ \ ( addr1 addr2 addr1 char) 346 | BASE @ DIGIT \ ( addr1 addr2 addr1 n flag) 347 | IF OVER BASE @ big*s \ ( addr1 addr2 addr1 n) 348 | big+s \ ( addr1 addr2) 349 | ELSE \ ( addr1 addr2 addr1 char) 350 | DROP LEAVE \ ( addr1 addr2) 351 | THEN 352 | CHAR+ 353 | LOOP 354 | R> OVER - ; 355 | 356 | 357 | : make_big_number ( addr1 u -- addr2) \ convert the u characters at addr1 358 | \ to a big number at addr2 359 | \ If the first character is "-" (ASCII 45) the result will be negative. 360 | \ embedded commas are ignored 361 | \ (USA representation convention for large numbers) 362 | \ Conversion stops at the first non-convertible character. 363 | 364 | OVER C@ \ Get the first character 365 | [CHAR] - = \ Is it a minus sign? 366 | DUP >R 367 | IF SWAP CHAR+ SWAP 1- THEN \ Adjust to next character 368 | \ ( addr1 u) 369 | HERE 1 , 0 , \ create big number = 0 370 | \ ( addr1 u addr2) 371 | ROT ROT 372 | BEGIN \ ( addr2 addr1 u) 373 | >big_number \ ( addr2 addr1 u) 374 | OVER C@ [CHAR] , = \ ( addr2 addr1 u flag) 375 | OVER AND 376 | WHILE 377 | SWAP CHAR+ SWAP 1- 378 | REPEAT 379 | 2DROP 380 | R> IF DUP bignegate THEN ; 381 | 382 | 383 | \ Words for big number output 384 | \ The words ( addr1 -- addr2 +n) \ "number sign big less". End big number 401 | \ pictured output conversion 402 | DROP bighld @ \ Start of string 403 | big_string 256 CHARS + \ One past end of string 404 | OVER - 1 CHARS / ; \ Length of string 405 | 406 | : big# ( addr -- addr) \ "big number sign" 407 | \ Generate the next ASCII character from the big number at addr. 408 | \ Afterward the big number at addr will hold the quotient obtained 409 | \ by dividing its previous value by the value in BASE. 410 | \ This result can then be used for further processing. 411 | \ Haydon p 18 412 | 413 | DUP 414 | BASE @ big/mods \ Next digit 415 | 9 OVER < \ Is it bigger than a decimal digit? 416 | IF 7 + THEN \ Add seven to its character representation, 417 | \ thus skipping the ASCII codes between 9 and A. 418 | 48 + \ Convert from number to ASCII character code. 419 | bighold ; \ add the character to the front of the output 420 | \ string 421 | 422 | : big#s ( addr -- addr) \ "big number sign s" Convert all digits of the 423 | \ big number at addr to big numeric output, leaving 424 | \ zero at addr 425 | BEGIN big# DUP @ 1 = \ Down to length 1 426 | OVER CELL+ @ 0= \ Remaining cell is zero 427 | AND 428 | UNTIL ; \ Haydon p 21. 429 | 430 | : bigsign ( n --) \ Put a minus sign in the big pictured numeric 431 | \ character output string if n is negative 432 | 0< IF 45 bighold THEN ; \ Haydon p 222. 433 | 434 | : bigstring ( addr1 sign -- ) \ Display the big number at addr1 with 435 | \ the sign of the number in sign. 436 | 437 | TYPE ; 438 | 439 | \ Words doing arithmetic on two big numbers 440 | 441 | big_digit_pointer long_addend big_digit_pointer short_addend 442 | 443 | : sum ( addr1 addr2 - addr3) \ addr3 has the result of adding the absolute 444 | \ value of the big number at addr1 to the absolute value of the big 445 | \ number at addr2. 446 | 447 | OVER @ ABS OVER @ ABS < \ compare the size of the addends 448 | IF SWAP THEN 449 | to_pointer short_addend 450 | to_pointer long_addend 451 | 452 | HERE \ address of result 453 | 0 , \ dummy placeholder for the count of the 454 | \ result 455 | 0 \ initialize carry 456 | 457 | 0 short_addend @ ABS 1+ \ for each digit in the short addend 458 | 1 \ starting at the first 459 | DO 460 | I short_addend @ + \ add digit to carry 461 | I long_addend @ + \ add digit to previous sum 462 | carry , \ new carry, append digit to result 463 | LOOP 464 | 465 | 0 long_addend @ ABS \ number of digits in long operand 466 | 1+ \ jog to make DO end on last digit 467 | 0 short_addend @ ABS \ number of digits in short operand 468 | 1+ \ jog to start DO on first digit 469 | \ not yet used 470 | ?DO I long_addend @ + \ append any remaining digits to the 471 | carry , \ result, rippling the carry as 472 | LOOP \ necessary 473 | 474 | 0 long_addend @ ABS \ result size so far 475 | SWAP 476 | IF 1 , 1+ THEN \ if final carry, append to result, 477 | \ bump size 478 | OVER ! ; \ store result size. 479 | 480 | big_digit_pointer minuend big_digit_pointer subtrahend 481 | 482 | : difference ( addr1 addr2 -- addr3) 483 | \ addr3 is the address of the difference of the absolute values of 484 | \ the big number at addr1 and the big number at addr2. 485 | 486 | HERE >R \ park address of result 487 | 2DUP |big|= 488 | IF 2DROP 1 , 0 , \ equal absolute values, result is zero 489 | ELSE 490 | 2DUP |big|< 491 | IF SWAP THEN 492 | to_pointer subtrahend 493 | to_pointer minuend 494 | 0 minuend @ ABS , \ count of the result 495 | 0 \ initialize borrow 496 | 497 | 0 minuend @ ABS 1+ \ for each minuend digit 498 | 1 \ starting with the first 499 | DO \ ( borrow) 500 | 0 \ next borrow 501 | I minuend @ \ get the ith minuend digit 502 | ROT - \ subtract previous borrow 503 | overflow? 504 | SWAP \ ( borrow result) 505 | 0 subtrahend 506 | I big_digit - \ subtract the ith subtrahend digit 507 | overflow? \ ( result borrow) 508 | SWAP , \ append result 509 | LOOP 510 | 511 | DROP \ Get rid of final borrow (it will be zero) 512 | R@ clip \ remove leading zeroes 513 | THEN 514 | R> ; \ address of result on stack 515 | 516 | 517 | big_digit_pointer multiplicand big_digit_pointer multiplier 518 | big_digit_pointer product 519 | 520 | : big_product ( addr1 addr2 -- addr3) \ addr3 has the result of multiplying 521 | \ the absolute value of the n digit operand at addr1 by the absolute 522 | \ value of the m digit operand at addr2. 523 | 524 | to_pointer multiplier 525 | to_pointer multiplicand \ store operand addresses 526 | HERE DUP to_pointer product \ address of result 527 | 0 multiplier @ ABS 528 | 0 multiplicand @ ABS 2DUP 529 | + , \ store product size 530 | 531 | \ allot and clear the first 532 | DUP 0 DO 0 , LOOP \ n digits of the product 533 | OVER CELLS ALLOT \ allot remaining digits of product 534 | 535 | OVER 1+ 1 \ for each multiplier digit, 536 | \ starting with the first 537 | DO 538 | 0 \ initial carry 539 | 540 | OVER 1+ 1 \ for each multiplicand digit, 541 | \ starting with the first 542 | DO 543 | I multiplicand @ \ mulitplicand digit times 544 | J multiplier @ \ multiplier digit 545 | M* 546 | I J 1- + >R \ current product digit index 547 | R@ product @ M+ \ add previous product result 548 | ROT M+ \ add carry 549 | D>carry \ split into digit & carry 550 | R> product ! \ store product digit 551 | LOOP 552 | 553 | OVER I + product ! \ store carry 554 | LOOP 555 | 2DROP 556 | DUP clip ; \ if there is a high-order zero, 557 | \ remove it 558 | 559 | 560 | big_digit_pointer dividend big_digit_pointer divisor 561 | big_digit_pointer quotient VARIABLE normalizer 562 | 563 | : divisor(n) ( -- n) \ n is the high digit of the divisor 564 | 0 divisor @ ABS divisor @ ; 565 | 566 | : divisor(n-1) ( -- n) \ n is the next-to-high-order digit of the divisor 567 | 0 divisor @ ABS 1- divisor @ ; 568 | 569 | : normalize ( -- ) \ Multiply dividend and divisor by a factor that 570 | \ will guarantee that the leading "digit" of the divisor will be 571 | \ > bigbase/2 572 | 573 | bigbd \ big number base as double number 574 | divisor(n) \ high order digit of divisor 575 | 1+ UM/MOD normalizer ! \ normalizing factor (base/(vn+1)) 576 | DROP \ discard remainder 577 | HERE \ This will be the address of the 578 | \ normalized dividend 579 | 0 dividend big>here \ copy dividend to end of data space 580 | to_pointer dividend \ new dividend address 581 | normalizer @ 1 > 582 | IF 0 dividend 583 | normalizer @ big*s \ normalize the dividend. 584 | THEN 585 | 0 , \ append high order zero to dividend 586 | 0 dividend DUP @ 0< \ negative dividend? 587 | IF -1 ELSE 1 THEN 588 | SWAP +! \ up the dividend digit count 589 | HERE \ address of the normalized divisor 590 | 0 divisor big>here \ copy divisor to end of data space 591 | DUP to_pointer divisor 592 | normalizer @ big*s ; \ normalize the divisor 593 | 594 | : big. ( addr --) \ "big dot" Display the big number at addr 595 | HERE >R R@ 596 | SWAP big>here \ Copy for nondestructive write 597 | DUP @ \ sign of the number 598 | SWAP bigstring 599 | SPACE 600 | R> HERE - ALLOT ; \ recover space used by big>here 601 | 602 | : big.digits ( addr --) \ "big dot digits" print the digits of the 603 | \ big number at addr 604 | DUP CELL+ SWAP DUP @ ABS CELLS + DO I ? -1 CELLS +LOOP ; 605 | 606 | : trial ( n1 -- n2) \ n2 is trial quotient digit n1 607 | \ CR ." trial " 608 | 0 divisor @ ABS + >R 609 | R@ dividend @ bigbase UM* \ u(j)*b 610 | R@ 1- dividend @ M+ \ [u(j)*b+u(j-1)] 611 | divisor(n) \ v(1), high digit of divisor 612 | R@ dividend @ = \ equal to uj? 613 | \ data stack: low[u(j)*b+u(j-1)] 614 | \ high[u(j)*b+u(j-1)] 615 | \ flag 616 | IF 2DROP 617 | R@ 1- dividend @ 618 | 0 divisor(n) M+ \ rhat = u(j-1) + v(1) 619 | biggest 620 | SWAP 621 | IF R> DROP EXIT THEN \ We have the right q 622 | ELSE divisor(n) UM/MOD \ rhat qhat 623 | THEN \ ( rhat qhat) (j) 624 | 625 | BEGIN \ test trial quotient 626 | 2DUP divisor(n-1) UM* \ v(n-1)*qhat 627 | ROT bigbase UM* \ rhat*b 628 | R@ 2 - dividend @ \ u(j-2) 629 | M+ 630 | 2SWAP D< 631 | WHILE \ ( rhat qhat) (j) 632 | 1- \ decrease trial quotient 633 | SWAP divisor(n) + \ adjust remainder 634 | SWAP 635 | REPEAT 636 | R> DROP \ clear return stack 637 | NIP ; \ drop trial remainder 638 | 639 | : div_subtract ( quotient j -- quotient flag) 640 | \ subtract (vn..v1)q from (u(j+n)..u(j)) 641 | \ flag is TRUE if the result is negative 642 | 0 \ borrow 643 | 0 divisor @ ABS 1+ 1 644 | DO \ ( quotient j borrow) 645 | >R 2DUP R> 646 | ROT I divisor @ M* 647 | D>carry \ convert from double number to 648 | \ big digits 649 | \ ( quotient j j borrow carry digit) 650 | ROT + \ add the previous borrow to the digit 651 | overflow? 652 | ROT dividend @ \ uj 653 | ROT - \ new uj 654 | BEGIN 655 | overflow? OVER 0< 656 | WHILE SWAP REPEAT 657 | >R \ park new borrow 658 | OVER dividend ! \ store new uj 659 | 1+ \ bump j 660 | R> 661 | LOOP 662 | OVER dividend @ 663 | SWAP - \ subtract the last borrow from the 664 | \ next digit of u 665 | DUP 666 | ROT dividend ! \ put the result in the digit of u 667 | 0<> ; \ test for overflow 668 | 669 | : addback ( j --) \ add (vn..v1) to (u(j+n)..u(j)) 670 | 0 \ carry 671 | 0 divisor @ ABS 1+ 1 672 | DO \ j carry 673 | OVER DUP dividend @ \ j carry j u(j) 674 | I divisor @ 675 | + ROT + \ j j (v(i)+u(j)+carry) 676 | carry 677 | ROT dividend ! 678 | SWAP 1+ SWAP \ increment j 679 | LOOP 680 | DUP 681 | IF \ Deal with the final carry (I'm not sure 682 | \ this is strictly necessary (If you can 683 | \ prove it one way or the other, I would be 684 | \ interested in seeing it) but it is neater) 685 | SWAP dividend +! 686 | ELSE 2DROP 687 | THEN ; 688 | 689 | 690 | : |divide| ( addr1 addr2 -- addr3) \ addr3 contains the result of dividing 691 | \ the absolute value of the big number at addr1 by the absolute value 692 | \ of the big number at addr2. The numbers must be unequal and the 693 | \ divisor must have at least two "digits". 694 | to_pointer divisor 695 | to_pointer dividend 696 | normalize 697 | HERE DUP \ address of quotient 698 | to_pointer quotient 699 | 1 \ limit for DO - stop after digit 1 700 | 0 dividend @ ABS \ number of digits in normalized dividend 701 | 0 divisor @ ABS \ number of digits in divisor 702 | - 1 MAX DUP , \ number of digits in quotient 703 | DUP CELLS ALLOT \ space for quotient 704 | DO 705 | I trial \ trial quotient digit 706 | I div_subtract 707 | IF 1- I addback THEN \ ( qi) 708 | I quotient ! \ store qi 709 | -1 +LOOP 710 | DUP clip ; 711 | 712 | 713 | : divide ( addr1 addr2 -- addr3) \ addr3 contains the result of dividing 714 | \ the absolute value of the big number at addr1 by the absolute value 715 | \ of the big number at addr2. 716 | 717 | 2DUP |big|< \ Is the number at addr1 < num at addr2? 718 | IF 2DROP HERE 1 , 0 , \ answer is 0 719 | ELSE 2DUP |big|= \ are the numbers equal? 720 | IF 2DROP HERE 1 , 1 , \ answer is 1 721 | ELSE DUP @ ABS 1 = \ single "digit" divisor? 722 | IF CELL+ @ \ divisor on stack 723 | HERE ROT big>here \ dividend to here 724 | DUP ROT big/mods 725 | DROP \ drop remainder 726 | DUP @ ABS \ absolute value for sign of quotient 727 | OVER ! 728 | ELSE |divide| 729 | THEN 730 | THEN 731 | THEN ; 732 | 733 | 734 | \ Finally! the words for the user. 735 | 736 | : big ( -- addr) \ addr is the address of the big number 737 | \ created from characters cccc in the input stream. 738 | BL WORD COUNT \ ( addr u) 739 | >R big_string R@ MOVE \ move characters from input stream to buffer 740 | big_string R> make_big_number ; 741 | 742 | 743 | big_digit_pointer op1 big_digit_pointer op2 744 | 745 | : big+ ( addr1 addr2 -- addr3) \ addr3 has the result of algebraically 746 | \ adding the operand at addr1 to the operand at addr2. 747 | 748 | HERE >R 749 | 2DUP to_pointer op2 750 | to_pointer op1 751 | 0 op1 @ 0 op2 @ XOR 752 | 0< IF difference \ operands are of opposite sign 753 | 0 op1 0 op2 |big|< 754 | IF 0 op2 @ \ result has the sign of operand 2 755 | ELSE 0 op1 0 op2 |big|= 756 | IF 1 \ result is zero, plus sign 757 | ELSE 0 op1 @ \ result has the sign of operand 1 758 | THEN 759 | THEN 760 | ELSE sum \ operands have same sign 761 | 0 op1 @ 762 | THEN 763 | OVER @ \ size of result 764 | SWAP 0< IF NEGATE THEN \ add the sign 765 | OVER ! 766 | R@ reposition R> ; 767 | 768 | : big- ( addr1 addr2 - addr3) \ addr3 has the result of algebraically 769 | \ subtracting the operand at addr2 from the operand at addr1. 770 | HERE >R big>here \ copy second operand 771 | R@ bignegate \ switch its sign 772 | R@ big+ \ add 773 | R@ reposition R> ; 774 | 775 | : big* ( addr1 addr2 -- addr3) \ addr3 is the address of the result of 776 | \ multiplying the operand at addr1 by the operand at addr2 777 | 2DUP big_product adjust_sign ; 778 | 779 | 780 | : big/ ( addr1 addr2 -- addr3) \ addr3 contains the floored quotient of 781 | \ the big number at addr1 dvided by the big number at addr2. 782 | \ addr3 is the value of HERE before the operation. 783 | HERE >R 784 | 2DUP divide 785 | ( adjust_sign) 786 | ROT @ ROT @ XOR 0< \ Do we need an adjustment? 787 | IF DUP 1 big+s DUP bignegate THEN 788 | R@ reposition R> ; 789 | 790 | \ big 288,265,561,597,526,014 big 17,593,259,786,239 big/ should leave a 791 | \ result of 16384. This tests the rare "trial divisor off by two" division 792 | \ branch on a 16 bit system. See Regener for more on this 793 | 794 | : bigmod ( addr1 addr2 -- addr3) \ addr3 is the remainder after dividing 795 | \ the big number at addr1 by the big number at addr2. addr3 is the value 796 | \ returned by HERE before the operation. 797 | HERE >R 798 | 2DUP big/ \ (addr1 addr2 qoutient-addr) 799 | big* big- 800 | R@ reposition R> ; 801 | 802 | : big/mod ( addr1 addr2 -- addr3 addr4) \ addr3 is the remainder and addr4 803 | \ is the quotient after dividing the big number at addr1 by the big 804 | \ number at addr2. 805 | 2DUP big/ 806 | DUP >R 807 | big* big- 808 | R> ; 809 | BASE ! \ End of file; restore BASE 810 | 811 | \ Bibliography & references: 812 | \ Haydon, Glen B. All About FORTH, An Annotated Glossary, Second edition 813 | \ 1984 MVP-FORTH Series Volume 1, Mounatin View Prees, Inc., P.O. Box 4656 814 | \ Mountain View CA 94040 USA. ISBN 0-914699-00-8. 815 | 816 | \ Knuth, Donald B. The Art of Computer Programming, Second Edition Volume 2 817 | \ Seminumerical Algorithms. Addison-Wesley Publishing Company Reading, 818 | \ Massachusetts USA 1961. ISBN 0-201-03822-6 (v.2) 819 | 820 | \ Regener, Eric "Multiprecision Integer Division Examples Using Arbitrary Radix" 821 | \ ACM Transactions on Mathematical SOftware, Vol 10 No. 3, September 1984 822 | \ pp 325-28. 823 | 824 | \ Ting, C. H. F-PC 3.5 Technical Reference Manual, Second Edition 1989. 825 | \ Offete Enterprises, Inc. 1306 South B Street San MAteo CA 94402 USA. 826 | \ 827 | \ ------end of file------ --------------------------------------------------------------------------------