├── hardware ├── stack │ ├── .gitignore │ ├── disassemble │ ├── hello.sh │ ├── kernel.sh │ ├── build.sh │ ├── disassemble.sh │ ├── machine.sh │ ├── hello.fs │ ├── bootstrap.sh │ ├── everything.sh │ ├── disassemble.c │ ├── bootstrap.fs │ ├── readme.md │ ├── machine.c │ └── assembler.fs ├── register │ ├── .gitignore │ ├── hello.sh │ ├── kernel.sh │ ├── build.sh │ ├── machine.sh │ ├── bootstrap.sh │ ├── everything.sh │ ├── debugger.fs │ ├── hello.fs │ ├── assembler.fs │ ├── machine.c │ ├── machine.fs │ ├── machine-test.fs │ ├── readme.md │ └── bootstrap.fs ├── register_v1 │ ├── .gitignore │ ├── assembler-adapter.f │ ├── machine.sh │ ├── bootstrap.sh │ ├── meta.sh │ ├── kernel.sh │ ├── test.f │ ├── test.sh │ ├── bootstrap.f │ ├── meta-test.sh │ ├── machine.htm │ ├── assembler.f │ ├── machine.c │ └── readme.md ├── register_v2 │ ├── .gitignore │ ├── me.bmp │ ├── test.sh │ ├── build.sh │ ├── run.sh │ ├── runsim.sh │ ├── assembler-test.fs │ ├── kernel-meta.fs │ ├── pixels.fs │ ├── sixels-color.fs │ ├── sixels.fs │ ├── machine-test.fs │ ├── debugger.fs │ ├── machine.fs │ ├── turtle-float.fs │ ├── assembler.fs │ ├── machine.c │ ├── turtle-fixed.fs │ ├── turtle-geometry-book.fs │ └── bootstrap.fs ├── register_v0 │ ├── .gitignore │ ├── machine.sh │ ├── bootstrap.sh │ ├── raw.sh │ ├── vt100.sh │ ├── assembler-adapter.f │ ├── screen.sh │ ├── kernel-adapter.f │ ├── meta.sh │ ├── kernel.sh │ ├── turtle-play.sh │ ├── pixels-test.sh │ ├── pixels-adapter.f │ ├── turtle-test.sh │ ├── snake.sh │ ├── test.sh │ ├── test.f │ ├── disassembler.fsproj │ ├── meta-test.sh │ ├── screen.f │ ├── vt100.f │ ├── turtle-fixed-point.f │ ├── snake.f │ ├── assembler.f │ ├── bootstrap.f │ ├── machine.c │ └── disassembler.fs ├── readme.md └── shared │ ├── memory.fs │ └── memory.c ├── .gitignore ├── boneyard └── interpreter │ ├── interpreter.sh │ └── interpreter.py ├── library ├── turtle │ ├── play.sh │ ├── turtle.f │ └── test.f ├── prelude-machine.f ├── pixels │ ├── pixels.f │ ├── test.f │ └── readme.md └── prelude-interpreter.f ├── license ├── notes ├── nybbleforth.md ├── todo.md ├── notes.md ├── outer-interpreter.md ├── transforth.md ├── instructions.md └── jonesforth.md └── readme.md /hardware/stack/.gitignore: -------------------------------------------------------------------------------- 1 | machine 2 | *.bin 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .gitattributes 2 | *.swp 3 | .DS_Store 4 | -------------------------------------------------------------------------------- /hardware/register/.gitignore: -------------------------------------------------------------------------------- 1 | machine 2 | *.bin 3 | obj/ 4 | -------------------------------------------------------------------------------- /hardware/register_v1/.gitignore: -------------------------------------------------------------------------------- 1 | .vs/ 2 | bin/ 3 | obj/ 4 | 5 | machine 6 | *.bin 7 | -------------------------------------------------------------------------------- /hardware/register_v2/.gitignore: -------------------------------------------------------------------------------- 1 | .vs/ 2 | bin/ 3 | obj/ 4 | 5 | machine 6 | *.bin 7 | -------------------------------------------------------------------------------- /hardware/register_v0/.gitignore: -------------------------------------------------------------------------------- 1 | .vs/ 2 | bin/ 3 | obj/ 4 | 5 | machine 6 | *.bin 7 | -------------------------------------------------------------------------------- /hardware/register_v2/me.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/AshleyF/Forthkit/HEAD/hardware/register_v2/me.bmp -------------------------------------------------------------------------------- /hardware/stack/disassemble: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/AshleyF/Forthkit/HEAD/hardware/stack/disassemble -------------------------------------------------------------------------------- /hardware/stack/hello.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | gforth -e "require hello.fs write-boot-block bye" 4 | ./machine.sh -------------------------------------------------------------------------------- /hardware/register/hello.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | gforth -e "require hello.fs write-boot-block bye" 4 | ./machine.sh -------------------------------------------------------------------------------- /hardware/register/kernel.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | gforth -e "require kernel.fs write-boot-block bye" 4 | ./machine.sh -------------------------------------------------------------------------------- /hardware/stack/kernel.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | gforth -e "require kernel.fs write-boot-block bye" 4 | ./machine.sh -------------------------------------------------------------------------------- /hardware/stack/build.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | rm -f ./machine 4 | gcc -Wall -O3 -std=c99 -fno-common -o ./machine ./machine.c 5 | -------------------------------------------------------------------------------- /hardware/register/build.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | rm -f ./machine 4 | gcc -Wall -O3 -std=c99 -fno-common -o ./machine ./machine.c 5 | -------------------------------------------------------------------------------- /boneyard/interpreter/interpreter.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | cat ../../library/prelude-interpreter.f - | python $(dirname $0)/interpreter.py 4 | -------------------------------------------------------------------------------- /hardware/register_v1/assembler-adapter.f: -------------------------------------------------------------------------------- 1 | create buffer 20000 allot 2 | 3 | : c! buffer + c! ; 4 | : ! buffer + ! ; 5 | : write buffer + write ; 6 | -------------------------------------------------------------------------------- /hardware/register_v0/machine.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | echo "Building machine..." 4 | rm -f machine 5 | gcc -Wall -O3 -std=c99 -o ./machine ./machine.c -------------------------------------------------------------------------------- /hardware/register_v1/machine.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | echo "Building machine..." 4 | rm -f machine 5 | gcc -Wall -O3 -std=c99 -o ./machine ./machine.c -------------------------------------------------------------------------------- /library/turtle/play.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | cat ../prelude-interpreter.f ../pixels/pixels.f ./turtle.f - | python ../../interpreter/interpreter.py 4 | -------------------------------------------------------------------------------- /hardware/register_v0/bootstrap.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | . ./kernel.sh 4 | . ./machine.sh 5 | echo "Running bootstrap..." 6 | cat ./bootstrap.f - | ./machine -------------------------------------------------------------------------------- /hardware/register_v0/raw.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | . ./machine.sh 4 | stty raw -echo # immediate key relay mode 5 | cat | ./machine 6 | stty sane # normal terminal mode 7 | -------------------------------------------------------------------------------- /hardware/register_v2/test.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | echo "Testing" 4 | cat ttester.fs tests.fs - | ./machine 5 | #cat bootstrap.fs ttester.fs tests.fs - | gforth debugger.fs -------------------------------------------------------------------------------- /hardware/register_v0/vt100.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | . ./kernel.sh 4 | . ./machine.sh 5 | echo "Running bootstrap with VT100..." 6 | cat ./bootstrap.f ./vt100.f - | ./machine -------------------------------------------------------------------------------- /library/prelude-machine.f: -------------------------------------------------------------------------------- 1 | ( shared library - machine prelude ) 2 | 3 | : +! dup @ rot + swap ! ; 4 | 5 | : 2drop drop drop ; 6 | 7 | : within rot swap over >= -rot <= and ; 8 | -------------------------------------------------------------------------------- /hardware/register_v0/assembler-adapter.f: -------------------------------------------------------------------------------- 1 | 20000 constant buffer 2 | 10000 constant bufsize 3 | 4 | : c! buffer + c! ; 5 | : ! buffer + ! ; 6 | 7 | : write rot buffer + -rot write ; 8 | -------------------------------------------------------------------------------- /hardware/register_v0/screen.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | . ./kernel.sh 4 | . ./machine.sh 5 | echo "Running bootstrap with screen..." 6 | cat ./bootstrap.f vt100.f ./screen.f - | ./machine -------------------------------------------------------------------------------- /hardware/register_v1/bootstrap.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | rm -f block1.bin # TODO remove 4 | . ./kernel.sh 5 | . ./machine.sh 6 | echo "Running bootstrap..." 7 | cat ./bootstrap.f - | ./machine -------------------------------------------------------------------------------- /hardware/register_v1/meta.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | . ./kernel.sh 4 | . ./machine.sh 5 | echo "Building meta-circular image..." 6 | cat ./bootstrap.f assembler-adapter.f ./assembler.f ./kernel.f | ./machine -------------------------------------------------------------------------------- /hardware/register_v0/kernel-adapter.f: -------------------------------------------------------------------------------- 1 | 2 | ( similar to in pixels-adapter.f but builds on stack rather than compiling ) 3 | : sym -1 begin 1+ key dup >r 32 = until r> drop dup begin r> -rot 1- dup 0 = until drop ; 4 | -------------------------------------------------------------------------------- /hardware/register_v0/meta.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | . ./kernel.sh 4 | . ./machine.sh 5 | echo "Building meta-circular image..." 6 | cat ./bootstrap.f assembler-adapter.f ./assembler.f kernel-adapter.f kernel.f | ./machine -------------------------------------------------------------------------------- /hardware/register_v0/kernel.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | echo "Building kernel image..." 4 | rm -f block0.bin 5 | cat ../../library/prelude-interpreter.f ./assembler.f ./kernel.f | python ../../interpreter/interpreter.py # build kernel image -------------------------------------------------------------------------------- /hardware/register_v1/kernel.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | echo "Building kernel image..." 4 | rm -f block0.bin 5 | cat ../../library/prelude-interpreter.f ./assembler.f ./kernel.f | python ../../interpreter/interpreter.py # build kernel image 6 | -------------------------------------------------------------------------------- /hardware/register_v0/turtle-play.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | . ./kernel.sh 4 | . ./machine.sh 5 | echo "Running turtle play..." 6 | cat ./bootstrap.f ../../library/prelude-machine.f pixels-adapter.f ../../library/pixels/pixels.f turtle-fixed-point.f - | ./machine -------------------------------------------------------------------------------- /hardware/stack/disassemble.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | echo "-- DISASSEMBLE -----------------------------------------------------------------" 4 | echo 5 | rm -f ./disassemble 6 | gcc -Wall -O3 -std=c99 -fno-common -o ./disassemble ./disassemble.c 7 | ./disassemble -------------------------------------------------------------------------------- /hardware/register_v0/pixels-test.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | . ./kernel.sh 4 | . ./machine.sh 5 | echo "Running pixels test..." 6 | cat ./bootstrap.f ../../library/prelude-machine.f pixels-adapter.f ../../library/pixels/pixels.f ../../library/pixels/test.f - | ./machine 7 | -------------------------------------------------------------------------------- /hardware/register_v0/pixels-adapter.f: -------------------------------------------------------------------------------- 1 | here 2 | 3208 allot ( 80×40+8 ) 3 | constant buffer 4 | 5 | : b@ buffer + c@ ; 6 | : b! buffer + c! ; 7 | 8 | : floor ; ( integer math already ) 9 | 10 | : sym 0 begin key swap 1+ swap dup literal 32 = until literal ; immediate 11 | -------------------------------------------------------------------------------- /hardware/register_v2/build.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | echo "Building machine..." 4 | rm -f ./machine 5 | gcc -Wall -O3 -std=c99 -o ./machine ./machine.c 6 | 7 | echo "Building image..." 8 | rm -f ./block0.bin 9 | echo "write-boot-block bye" | cat bootstrap.fs - | gforth debugger.fs -------------------------------------------------------------------------------- /hardware/register_v0/turtle-test.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | . ./kernel.sh 4 | . ./machine.sh 5 | echo "Running turtle test..." 6 | cat ./bootstrap.f ../../library/prelude-machine.f pixels-adapter.f ../../library/pixels/pixels.f turtle-fixed-point.f ../../library/turtle/test.f - | ./machine 7 | -------------------------------------------------------------------------------- /hardware/register_v1/test.f: -------------------------------------------------------------------------------- 1 | 12 constant one 2 | 13 constant x 3 | 14 constant y 4 | 15 constant z 5 | 6 | 1 one ldc, 7 | 32 y ldc, 8 | 9 | label 'loop 10 | x in, 11 | z x one add, 12 | 'loop z jmz, 13 | x x y sub, 14 | x out, 15 | 'loop jump, 16 | 17 | assemble 18 | -------------------------------------------------------------------------------- /hardware/register_v2/run.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | echo "Running" 4 | cat pixels.fs turtle-fixed.fs turtle-geometry-book.fs - | ./machine 5 | #cat pixels.fs sixels.fs turtle-fixed.fs turtle-geometry-book.fs - | ./machine 6 | #cat sixels-color.fs turtle-fixed.fs turtle-geometry-book.fs - | ./machine 7 | -------------------------------------------------------------------------------- /hardware/readme.md: -------------------------------------------------------------------------------- 1 | # "Hardware" 2 | 3 | Virtual "hardware" targets as virtual machines: 4 | 5 | * [Register machine](./register/) with return stack (`call`/`ret` instructions) 6 | * TODO: Register machine without `call`/`ret` instructions 7 | * TODO: Stack machine 8 | * TODO: GreenArray style multi-core machine 9 | -------------------------------------------------------------------------------- /hardware/register_v0/snake.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | . ./kernel.sh 4 | . ./machine.sh 5 | echo "Running snake with raw terminal input..." 6 | stty raw -echo # immediate key relay mode 7 | cat ./bootstrap.f ../../library/prelude-machine.f ./vt100.f ./screen.f ./snake.f - | ./machine 8 | stty sane # normal terminal mode -------------------------------------------------------------------------------- /hardware/register_v0/test.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | echo "Building test image..." 4 | rm -f block0.bin 5 | cat ../../library/prelude-interpreter.f ./assembler.f ./test.f | python ../../interpreter/interpreter.py 6 | . ./machine.sh 7 | echo "Running test image (type something in lowercase and press ENTER)" 8 | ./machine 9 | -------------------------------------------------------------------------------- /hardware/register_v1/test.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | echo "Building test image..." 4 | rm -f block0.bin 5 | cat ../../library/prelude-interpreter.f ./assembler.f ./test.f | python ../../interpreter/interpreter.py 6 | . ./machine.sh 7 | echo "Running test image (type something in lowercase and press ENTER)" 8 | ./machine 9 | -------------------------------------------------------------------------------- /hardware/register/machine.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | echo "-- NATIVE MACHINE --------------------------------------------------------------" 4 | echo 5 | ./build.sh && ./machine 6 | 7 | echo 8 | echo "-- FORTH MACHINE ---------------------------------------------------------------" 9 | echo 10 | cat - | gforth -e "require machine.fs reboot" -------------------------------------------------------------------------------- /hardware/register_v0/test.f: -------------------------------------------------------------------------------- 1 | ( simple assembler/VM test - capitalize [-32] console input ) 2 | ( requires assembler ) 3 | 4 | 0 constant u 5 | 1 constant c 6 | 2 constant z 7 | 8 | u 32 ldc, 9 | label &start 10 | c in, 11 | c z &start blt, 12 | c u c sub, 13 | c out, 14 | &start jump, 15 | 16 | assemble 17 | -------------------------------------------------------------------------------- /hardware/stack/machine.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | echo "-- NATIVE MACHINE --------------------------------------------------------------" 4 | echo 5 | ./build.sh && ./machine 6 | 7 | # echo 8 | # echo "-- FORTH MACHINE ---------------------------------------------------------------" 9 | # echo 10 | # cat - | gforth -e "require machine.fs reboot" -------------------------------------------------------------------------------- /hardware/register_v2/runsim.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | echo "Running simulator" 4 | cat bootstrap.fs pixels.fs turtle-fixed.fs turtle-geometry-book.fs - | gforth debugger.fs 5 | # cat bootstrap.fs pixels.fs sixels.fs turtle-fixed.fs turtle-geometry-book.fs - | gforth debugger.fs 6 | # cat bootstrap.fs sixels-color.fs turtle-fixed.fs turtle-geometry-book.fs - | gforth debugger.fs -------------------------------------------------------------------------------- /hardware/register_v2/assembler-test.fs: -------------------------------------------------------------------------------- 1 | require assembler.fs 2 | 3 | 2 constant upper 4 | 3 constant x 5 | 6 | 32 upper ldc, \ 1220 LDC upper $20 7 | 8 | label 'loop \ 'loop = 0002 9 | x in, \ C3 IN x 10 | x x upper sub, \ 6233 SUB upper x x 11 | x out, \ D3 OUT x 12 | 'loop jump, \ 2100 0200 LD+ zero pc pc 0002 13 | 14 | write-boot-block bye -------------------------------------------------------------------------------- /hardware/stack/hello.fs: -------------------------------------------------------------------------------- 1 | require assembler.fs 2 | 3 | skip, 4 | 5 | label 'message 6 | 12 c, 7 | char H c, 8 | char e c, 9 | char l c, 10 | char l c, 11 | char o c, 12 | char , c, 13 | bl c, 14 | char W c, 15 | char o c, 16 | char r c, 17 | char l c, 18 | char d c, 19 | char ! c, 20 | 21 | start, 22 | 23 | 'message literal, 24 | ld8+, \ get length 25 | for, 26 | ld8+, out, \ output character 27 | next, 28 | drop, zero, halt, -------------------------------------------------------------------------------- /hardware/register/bootstrap.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | gforth -e "require kernel.fs write-boot-block bye" 4 | 5 | echo "-- BOOTSTRAP NATIVE MACHINE ----------------------------------------------------" 6 | echo 7 | ./build.sh && cat bootstrap.fs - | ./machine 8 | 9 | echo 10 | echo "-- BOOTSTRAP FORTH MACHINE -----------------------------------------------------" 11 | echo 12 | cat bootstrap.fs - | gforth -e "require machine.fs reboot" 13 | -------------------------------------------------------------------------------- /hardware/stack/bootstrap.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | gforth -e "require kernel.fs write-boot-block bye" 4 | 5 | echo "-- BOOTSTRAP NATIVE MACHINE ----------------------------------------------------" 6 | echo 7 | ./build.sh && cat bootstrap.fs - | ./machine 8 | 9 | # echo 10 | # echo "-- BOOTSTRAP FORTH MACHINE -----------------------------------------------------" 11 | # echo 12 | # cat bootstrap.fs - | gforth -e "require machine.fs reboot" 13 | -------------------------------------------------------------------------------- /hardware/register_v0/disassembler.fsproj: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | Exe 5 | net8.0 6 | 7 | 8 | 9 | True 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | -------------------------------------------------------------------------------- /hardware/register_v1/bootstrap.f: -------------------------------------------------------------------------------- 1 | make : ] make ] ; 2 | 3 | : constant create , does> @ ; 4 | 5 | 32 constant bl 6 | 2 constant cell 7 | 8 | : cell+ cell + ; 9 | : cells cell * ; 10 | 11 | : variable create 1 cells allot ; 12 | 13 | : point create , , does> dup cell+ @ swap @ ; 14 | 15 | : [char] parse-name drop c@ postpone literal ; immediate 16 | 17 | : ( [char] ) parse 2drop ; immediate 18 | : \ 10 ( newline ) parse 2drop ; immediate 19 | 20 | ( now we can use comments like this! ) 21 | \ or like this to the end of the line! 22 | -------------------------------------------------------------------------------- /hardware/register/everything.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | echo "== TESTING MACHINE =============================================================" 4 | echo 5 | gforth machine-test.fs 6 | 7 | echo 8 | echo 9 | echo "== HELLO WORLD =================================================================" 10 | echo 11 | ./hello.sh 12 | 13 | echo 14 | echo "== RUN KERNEL (manually test, then bye) ========================================" 15 | echo 16 | ./kernel.sh 17 | 18 | echo 19 | echo "== RUN BOOTSTRAP (manually test, then bye) =====================================" 20 | echo 21 | ./bootstrap.sh 22 | -------------------------------------------------------------------------------- /hardware/stack/everything.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | # echo "== TESTING MACHINE =============================================================" 4 | # echo 5 | # gforth machine-test.fs 6 | 7 | echo 8 | echo 9 | echo "== HELLO WORLD =================================================================" 10 | echo 11 | ./hello.sh 12 | 13 | echo 14 | echo "== RUN KERNEL (manually test, then bye) ========================================" 15 | echo 16 | ./kernel.sh 17 | 18 | echo 19 | echo "== RUN BOOTSTRAP (manually test, then bye) =====================================" 20 | echo 21 | ./bootstrap.sh 22 | -------------------------------------------------------------------------------- /hardware/register/debugger.fs: -------------------------------------------------------------------------------- 1 | 2 | false warnings ! \ redefining gforth words 3 | 4 | : (bye) cr ." HALT" cr quit ; \ quit back to gforth REPL without exiting process 5 | 6 | true warnings ! 7 | 8 | require machine.fs 9 | 10 | : dump-register ( r -- ) reg @ . ; 11 | : dump-all-registers ( -- ) registers 16 cells dump ; 12 | 13 | : dump-memory ( -- ) memory here 1- dump ; 14 | : dump-all-memory ( -- ) memory memory-size dump ; 15 | 16 | require assembler.fs 17 | 18 | : run-word ( addr -- ) pc reg ! run ; 19 | 20 | require kernel.fs 21 | 22 | \ label 'test ' (skipws) call, 23 | \ : test 'test run-word ; 24 | -------------------------------------------------------------------------------- /hardware/register_v0/meta-test.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | rm ./block0.bin 4 | rm ./kernel.bin 5 | 6 | . ./kernel.sh # build kernel using Python 7 | mv ./block0.bin ./kernel.bin 8 | 9 | . ./meta.sh # build kernel using machine 10 | 11 | diff -s <(xxd block0.bin) <(xxd kernel.bin) 12 | 13 | # go around again! 14 | cat ./bootstrap.f assembler-adapter.f ./assembler.f kernel-adapter.f kernel.f | ./machine 15 | 16 | diff -s <(xxd block0.bin) <(xxd kernel.bin) 17 | 18 | rm ./kernel.bin 19 | 20 | echo "Running turtle test..." 21 | cat ./bootstrap.f ../../library/prelude-machine.f pixels-adapter.f ../../library/pixels/pixels.f turtle-fixed-point.f ../../library/turtle/test.f - | ./machine -------------------------------------------------------------------------------- /hardware/register_v1/meta-test.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | rm ./block0.bin 4 | rm ./kernel.bin 5 | 6 | . ./kernel.sh # build kernel using Python 7 | mv ./block0.bin ./kernel.bin 8 | 9 | . ./meta.sh # build kernel using machine 10 | 11 | diff -s <(xxd block0.bin) <(xxd kernel.bin) 12 | 13 | # go around again! 14 | rm ./block0.bin 15 | cat ./bootstrap.f assembler-adapter.f ./assembler.f ./kernel.f | ./machine 16 | 17 | diff -s <(xxd block0.bin) <(xxd kernel.bin) 18 | 19 | rm ./kernel.bin 20 | 21 | # echo "Running turtle test..." 22 | # cat ./bootstrap.f ../../library/prelude-machine.f pixels-adapter.f ../../library/pixels/pixels.f turtle-fixed-point.f ../../library/turtle/test.f - | ./machine -------------------------------------------------------------------------------- /hardware/register_v0/screen.f: -------------------------------------------------------------------------------- 1 | ( screen buffer ) 2 | 3 | 80 constant width 4 | 40 constant height 5 | width height * constant size 6 | 7 | here size 2 * allot constant buffer0 8 | here size 2 * allot constant buffer1 9 | 10 | : clear size 0 do 32 buffer1 i 2 * + ! loop ; 11 | 12 | : update 13 | vthide 14 | height 0 do 15 | width 0 do 16 | width j * i + 2 * 17 | dup buffer0 + 18 | swap buffer1 + 19 | 2dup @ swap @ <> if 20 | @ dup i j vthome emit 21 | swap ! 22 | else 23 | drop drop 24 | then 25 | loop 26 | loop 27 | 0 height 1 + vthome vtshow ; 28 | 29 | : coord width * + 2 * buffer1 + ; 30 | : set coord ! ; 31 | : get coord @ ; 32 | -------------------------------------------------------------------------------- /library/pixels/pixels.f: -------------------------------------------------------------------------------- 1 | ( pixel graphics library using Unicode Braille characters ) 2 | ( requires: prelude ) 3 | 4 | 160 constant width 5 | 160 constant height 6 | 7 | width 2 / constant columns 8 | width height * 8 / constant size 9 | 10 | ( init dot masks ) 11 | : init-masks 8 0 do size i + b! loop ; 12 | 128 64 32 4 16 2 8 1 init-masks 13 | 14 | : clear size 0 do 0 i b! loop ; 15 | 16 | : cell 4 / floor columns * swap 2 / floor + ; 17 | : mask 4 mod 2 * swap 2 mod + size + b@ ; 18 | : cell-mask 2dup cell -rot mask over b@ ; 19 | 20 | : set cell-mask or swap b! ; 21 | : reset cell-mask swap invert and swap b! ; 22 | 23 | : show 24 | size 0 do 25 | i columns mod 0 = if 10 emit then ( newline as appropriate ) 26 | i b@ 10240 or emit 27 | loop ; 28 | -------------------------------------------------------------------------------- /library/prelude-interpreter.f: -------------------------------------------------------------------------------- 1 | ( shared library - interpreter prelude ) 2 | 3 | : 2dup over over ; 4 | : 2drop drop drop ; 5 | 6 | : dup 0 pick ; 7 | : over 1 pick ; 8 | : swap 1 roll ; 9 | : rot 2 roll ; 10 | : -rot rot rot ; 11 | 12 | : invert dup nand ; 13 | : and nand invert ; 14 | : or invert swap invert nand ; 15 | : xor 2dup and invert -rot or and ; 16 | : nor or invert ; 17 | : xnor xor invert ; 18 | 19 | : min 2dup > if swap then drop ; 20 | : max 2dup < if swap then drop ; 21 | : within rot swap over >= -rot <= and ; 22 | 23 | : negate -1 * ; 24 | : abs dup 0 < if negate then ; 25 | 26 | : +! dup @ rot + swap ! ; 27 | 28 | : 0= 0 = ; 29 | : 0<> 0 <> ; 30 | : 0< 0 < ; 31 | : 0> 0 > ; 32 | 33 | : /mod 2dup / -rot mod ; 34 | 35 | : factorial dup 1 > if dup 1- recurse * then ; 36 | -------------------------------------------------------------------------------- /library/turtle/turtle.f: -------------------------------------------------------------------------------- 1 | ( turtle graphics ) 2 | ( requires: pixels.f ) 3 | 4 | variable x variable y variable theta ( initialized in start ) 5 | variable dx variable dy 6 | 7 | : point-x x @ width 2 / + 0.5 + floor ; 8 | : point-y y @ height 2 / + 0.5 + floor ; 9 | : valid-x? point-x 0 width 1 - within ; 10 | : valid-y? point-y 0 height 1 - within ; 11 | : valid? valid-x? valid-y? and ; 12 | : plot valid? if point-x point-y set then ; 13 | 14 | 3.14159265359 constant pi 15 | pi 180.0 / constant rads 16 | 180.0 pi / constant degs 17 | : deg2rad rads * ; 18 | : rad2deg degs * ; 19 | 20 | : go y ! x ! ; 21 | : head dup theta ! deg2rad dup cos dx ! sin dy ! ; 22 | : pose head go ; 23 | 24 | : start clear 0 0 0 pose ; 25 | : turn theta @ + head ; 26 | : move 0 do dx @ x +! dy @ y +! plot loop ; 27 | : jump dup dx @ * x +! dy @ * y +! ; 28 | -------------------------------------------------------------------------------- /hardware/register/hello.fs: -------------------------------------------------------------------------------- 1 | require assembler.fs 2 | 3 | skip, 4 | 5 | label 'message 6 | char H c, 7 | char e c, 8 | char l c, 9 | char l c, 10 | char o c, 11 | char , c, 12 | bl c, 13 | char W c, 14 | char o c, 15 | char r c, 16 | char l c, 17 | char d c, 18 | char ! c, 19 | 0 c, 20 | 21 | label 'halt 22 | zero halt, 23 | 24 | start, 25 | 26 | 2 constant one 1 one lit8, \ literal 1 27 | 3 constant eight 8 eight lit8, \ literal 8 28 | 29 | 4 constant halt-addr 'halt halt-addr lit8, 30 | 5 constant mask mask mask not, mask mask eight shr, 31 | 32 | 6 constant msg 'message msg lit8, 33 | 7 constant ch 34 | 35 | label 'print 36 | ch msg one ld16+, \ ch = memory[msg++] 37 | ch ch mask and, \ single byte 38 | pc halt-addr ch cp?, \ if ch == 0, pc=halt-addr (jump out) 39 | ch out, \ output character 40 | 'print jump, \ jump back to 'print -------------------------------------------------------------------------------- /hardware/shared/memory.fs: -------------------------------------------------------------------------------- 1 | $10000 constant memory-size 2 | create memory memory-size allot \ memory-size buffer: memory (buffer: not in old gforth) 3 | memory memory-size erase 4 | variable h memory h ! 5 | 6 | : s! ( val addr -- ) memory + over 8 rshift over 1+ c! c! ; 7 | : s@ ( addr -- val ) memory + dup c@ swap 1+ c@ 8 lshift or ; 8 | 9 | : block-file ( n -- addr len ) s" block" rot 0 <# #s #> s+ s" .bin" s+ ; 10 | 11 | : read-block ( block addr len ) 12 | rot block-file 2dup file-status 0<> if ." Block file not found " else drop then 13 | r/o open-file throw 14 | rot memory + -rot dup >r 15 | read-file throw drop r> 16 | close-file throw ; 17 | 18 | : write-block ( block addr len ) 19 | rot block-file w/o create-file throw 20 | rot memory + -rot dup >r 21 | write-file throw r> 22 | close-file throw ; 23 | 24 | : read-boot-block ( -- ) 0 0 memory-size read-block ; -------------------------------------------------------------------------------- /hardware/register_v1/machine.htm: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | RM16 7 | 16 | 17 | 18 |

RM16

19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 |
ControlsTerminal
Registers
Memory
31 | 32 | -------------------------------------------------------------------------------- /hardware/register_v2/kernel-meta.fs: -------------------------------------------------------------------------------- 1 | 65536 constant memory-size 2 | 3 | 0 dp ! \ begin image 4 | 5 | 1 one ldc, \ literal 1 6 | 2 two ldc, \ literal 2 7 | 4 four ldc, \ literal 4 8 | 8 eight ldc, \ literal 8 9 | 12 twelve ldc, \ literal 12 10 | -1 #t ldc, \ literal true (-1) 11 | 12 | memory-size r ldv, \ return stack pointer 13 | 14 | branch, \ skip dictionary 15 | 16 | : (clear-data) [ memory-size 2 + d ldv, ] ; 17 | : (clear-return) [ 18 | x popr, 19 | memory-size r ldv, 20 | x x four add, \ ret, 21 | pc x cp, 22 | 23 | : decimal 10 base ! ; 24 | 25 | : quit ; 26 | 27 | patch, 28 | 29 | ] (clear-data) decimal quit ( TODO jump ) [ 30 | 31 | \ here ' dp 16 + s! \ update dictionary pointer to compile-time position 32 | \ latest @ ' latest 16 + s! \ update latest to compile-time 33 | 34 | here . 35 | 0 here 0 write-block 36 | \ bye -------------------------------------------------------------------------------- /hardware/shared/memory.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | unsigned char mem[0x10000]; 4 | 5 | FILE* openBlock(unsigned short block, const char * mode) 6 | { 7 | char filename[0xf]; 8 | snprintf(filename, sizeof(filename), "block%d.bin", block); 9 | return fopen(filename, mode); 10 | } 11 | 12 | void readBlock(unsigned short block, unsigned short address, long maxsize) 13 | { 14 | FILE *file = openBlock(block, "r"); 15 | fseek(file, 0, SEEK_END); 16 | long size = ftell(file); 17 | fseek(file, 0, SEEK_SET); 18 | if (!file || !fread(mem + address, maxsize < size ? maxsize : size, 1, file)) // assumes size+address <= sizeof(mem) 19 | { 20 | printf("Could not open block file.\n"); 21 | } 22 | fclose(file); 23 | } 24 | 25 | void writeBlock(unsigned short block, unsigned short address, long size) 26 | { 27 | FILE *file = openBlock(block, "w"); 28 | if (!file || !fwrite(mem + address, 1, size, file)) 29 | { 30 | printf("Could not write block file.\n"); 31 | } 32 | fclose(file); 33 | } -------------------------------------------------------------------------------- /hardware/register_v0/vt100.f: -------------------------------------------------------------------------------- 1 | ( VT100 terminal commands ) 2 | 3 | : esc 27 emit ; 4 | : bracket char [ emit ; 5 | : semi char ; emit ; 6 | 7 | : vthome ( cr- ) esc bracket 1+ . semi 1+ . char H emit ; ( TODO: multi-digit ) 8 | : vtclear esc bracket char 2 emit char J emit ; 9 | : vtreset esc char c emit ; 10 | 11 | : vtattribs esc bracket dup 0 do swap num dup i 1+ > if semi then loop char m emit ; 12 | : vtattrib 1 vtattribs ; 13 | 14 | 30 constant vtblack 15 | 31 constant vtred 16 | 32 constant vtgreen 17 | 33 constant vtyellow 18 | 34 constant vtblue 19 | 35 constant vtmagenta 20 | 36 constant vtcyan 21 | 37 constant vtwhite 22 | 23 | 0 constant vtreset 24 | 1 constant vtbright 25 | 2 constant vtdim 26 | 4 constant vtunderscore 27 | 5 constant vtblink 28 | 7 constant vtreverse 29 | 8 constant vthidden 30 | 31 | : vtfg ( f- ) vtattrib ; 32 | : vtbg ( b- ) 10 + vtattrib ; ( background = foreground + 10 ) 33 | : vtcolors ( fb- ) 10 + 2 vtattribs ; ( background = foreground + 10 ) 34 | 35 | : vthide esc bracket char ? emit 25 num char l emit ; 36 | : vtshow esc bracket char ? emit 25 num char h emit ; 37 | -------------------------------------------------------------------------------- /license: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2017 Ashley Nathan Feniello 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /hardware/register_v2/pixels.fs: -------------------------------------------------------------------------------- 1 | \ pixel graphics library using Unicode Braille characters 2 | 3 | \ : buffer: create allot ; \ TODO: not defined in gforth?! 4 | 5 | 160 constant width 6 | 160 constant height 7 | 8 | width 2 / constant columns 9 | width height * 8 / constant size 10 | 11 | size buffer: screen 12 | create mask-table 1 c, 8 c, 2 c, 16 c, 4 c, 32 c, 64 c, 128 c, 13 | 14 | : clear ( -- ) 15 | screen size + screen do 0 i c! loop ; 16 | 17 | : char-cell ( x y -- cell ) 18 | 4 / columns * swap 2 / + ; 19 | 20 | : mask ( x y -- mask ) 21 | 4 mod 2 * swap 2 mod + mask-table + c@ ; 22 | 23 | : char-cell-mask ( x y -- cell mask char ) 24 | 2dup char-cell -rot mask over screen + c@ ; 25 | 26 | : set ( x y -- ) 27 | char-cell-mask or swap screen + c! ; 28 | 29 | : get ( x y -- b ) 30 | char-cell-mask and swap drop 0<> ; 31 | 32 | : reset ( x y -- ) 33 | char-cell-mask swap invert and swap screen + c! ; 34 | 35 | : u>= ( u1 u2 -- flag ) 36 | u< 0= ; 37 | 38 | : utf8-emit ( c -- ) 39 | dup 128 < if emit exit then 40 | 0 swap 63 begin 2dup > while 2/ >r dup 63 and 128 or swap 6 rshift r> repeat 41 | 127 xor 2* or begin dup 128 u>= while emit repeat drop ; 42 | 43 | : show 44 | size 0 do 45 | i columns mod 0= if 10 emit then \ newline as appropriate 46 | i screen + c@ 10240 or utf8-emit 47 | loop ; 48 | -------------------------------------------------------------------------------- /library/pixels/test.f: -------------------------------------------------------------------------------- 1 | ( test plotting with pixels ) 2 | ( requires: pixels ) 3 | 4 | variable x variable y 5 | 6 | : start clear 0 x ! 0 y ! ; 7 | : | 0 do 35 = if x @ y @ set then 1 x +! loop 0 x ! 1 y +! ; 8 | 9 | : turtle start 10 | sym ```````````````````````````````####`` | 11 | sym `````````````````````````````##````#` | 12 | sym ```````````#######``````````#```````# | 13 | sym ````````####```#``##```````#````#```# | 14 | sym ``````##`###```###``##`````#````````# | 15 | sym `````##`#```#`#```#`#`#```#`````````# | 16 | sym ````#``#`````#`````#```#``#``````###` | 17 | sym ```#``#`#```#`#```#`#`#####```````#`` | 18 | sym ``####```###```###``##````#`````##``` | 19 | sym `##``#```#`#```#```#`````#`````#````` | 20 | sym #``#`#```#`#```#``#``````#````#`````` | 21 | sym #```#`#`#`#`#`#`##`````##````#``````` | 22 | sym #````###########`````##`````##``````` | 23 | sym `#``````````````````#``````##```````` | 24 | sym ``#```````````````##`##```#`#```````` | 25 | sym ``################`#```###`#````````` | 26 | sym `#```#````````#````#``````#`````````` | 27 | sym #```###```````#```#`````##`##```````` | 28 | sym #``#```#######````#######````#``````` | 29 | sym `##`````````#````#```````#```#``````` | 30 | sym ````````````#```#`````````###```````` | 31 | sym `````````````###````````````````````` | 32 | show ; 33 | 34 | turtle 35 | -------------------------------------------------------------------------------- /hardware/register_v2/sixels-color.fs: -------------------------------------------------------------------------------- 1 | : buffer: create allot ; \ TODO: not defined in gforth?! 2 | 3 | 160 constant width 4 | 160 constant height 5 | 6 | 27 constant esc 7 | 8 | variable r 100 r ! 9 | variable g 0 g ! 10 | variable b 0 b ! 11 | : next-color 12 | r @ 100 = b @ 0 = and g @ 100 < and if 1 g +! 13 | else g @ 100 = b @ 0 = and r @ 0 > and if -1 r +! 14 | else r @ 0= g @ 100 = and b @ 100 < and if 1 b +! 15 | else r @ 0= b @ 100 = and g @ 0 > and if -1 g +! 16 | else g @ 0= b @ 100 = and r @ 100 < and if 1 r +! 17 | else r @ 100 = g @ 0 = and b @ 0 > and if -1 b +! 18 | then then then then then then ; 19 | : emit-num s>d <# #s #> type ; 20 | : set-color 21 | ." #0;2;" 22 | r @ emit-num [char] ; emit 23 | g @ emit-num [char] ; emit 24 | b @ emit-num 25 | next-color ; 26 | 27 | : home-cursor esc emit ." [H" ; 28 | : clear 29 | esc emit ." [40m" \ black background 30 | esc emit ." [2J" \ clear 31 | home-cursor ; 32 | : set ( x y -- ) 33 | home-cursor 34 | esc emit ." P;1q" 35 | [char] " emit ." 1;1" \ 1:1 pad:pan ratio (square pixels) 36 | set-color 37 | dup 6 / 0 ?do [char] - emit loop \ to line 38 | swap [char] ! emit emit-num 63 emit 39 | \ swap 0 ?do 63 emit loop \ to column \ TODO: use repeat protocol 40 | 6 mod 2 swap power 63 + \ sixel 41 | emit 42 | esc emit [char] \ emit 43 | ; \ 10000 0 do loop ; 44 | 45 | : show 100 0 do 10000 0 do loop loop ; \ pause 46 | \ : show ; 47 | -------------------------------------------------------------------------------- /hardware/register_v1/assembler.f: -------------------------------------------------------------------------------- 1 | variable h 0 h ! 2 | : here h @ ; 3 | : , here ! here 2 + h ! ; 4 | : c, here ! here 1 + h ! ; 5 | 6 | : 2nyb, 4 lshift or c, ; 7 | : 4nyb, 2nyb, 2nyb, ; 8 | 9 | : halt, 0 2nyb, ; 10 | : ldc, 1 2nyb, c, ; 11 | : ld+, 2 4nyb, ; 12 | : st+, 3 4nyb, ; 13 | : cp?, 4 4nyb, ; 14 | : add, 5 4nyb, ; 15 | : sub, 6 4nyb, ; 16 | : mul, 7 4nyb, ; 17 | : div, 8 4nyb, ; 18 | : nand, 9 4nyb, ; 19 | : shl, 10 4nyb, ; 20 | : shr, 11 4nyb, ; 21 | : in, 12 2nyb, ; 22 | : out, 13 2nyb, ; 23 | : read, 14 4nyb, ; 24 | : write, 15 4nyb, ; 25 | 26 | : label here constant ; 27 | : assemble 0 here 0 write halt ; 28 | 29 | 0 constant pc 30 | 1 constant zero 31 | 2 constant two 32 | 3 constant t 33 | 34 | 2 two ldc, 35 | 36 | : cp, zero cp?, ; 37 | : ld, zero ld+, ; 38 | : st, zero st+, ; 39 | 40 | : lit, pc two ld+, , ; 41 | : jump, pc pc ld, , ; 42 | : jmz, swap t lit, pc t rot cp?, ; ( uses t ) 43 | 44 | : not, dup nand, ; 45 | : and, 2 pick -rot nand, dup not, ; 46 | 47 | : or, dup dup not, over dup not, nand, ; 48 | ( TODO xor nor xnor ) 49 | 50 | ( TODO: needed? ) 51 | : zero, 0 swap ldc, ; ( TODO: with nand? ) 52 | : one, 1 swap ldc, ; 53 | : -one, -1 swap ldc, ; 54 | 55 | : inc, t one, t swap add, ; ( uses t ) 56 | : dec, t -one, t swap add, ; ( uses t ) 57 | 58 | : negate, swap over not, dup inc, ; ( uses t via inc, ) 59 | 60 | : ahead, here 2 + 0 zero jmz, ; ( dummy jump, push address ) 61 | : continue, here swap ! ; ( patch jump ) 62 | -------------------------------------------------------------------------------- /hardware/register_v2/sixels.fs: -------------------------------------------------------------------------------- 1 | : buffer: create allot ; \ TODO: not defined in gforth?! 2 | 3 | 160 constant width 4 | 160 constant height 5 | 6 | 27 constant esc 7 | 8 | : show-sixel 9 | esc emit ." P;1q" 10 | [char] " emit ." 1;1" \ 1:1 pad:pan ratio (square pixels) 11 | height 0 do \ TODO: missed bottom rows 12 | width 0 do 13 | 0 14 | i j get if 7 or then 15 | j height 1 - < if 16 | i j 1 + get if 56 or then 17 | then 18 | 63 + dup emit dup emit emit 19 | loop 20 | [char] - emit 21 | 2 +loop 22 | esc emit [char] \ emit cr ; 23 | 24 | : show-sixel-tiny 25 | esc emit ." P;1q" \ transparent zero pixel value (also, default 0 aspect ratio -- override below) 26 | [char] " emit ." 1;1" \ 1:1 pad:pan ratio (square pixels) 27 | height 0 do \ TODO: missed bottom rows 28 | width 0 do 29 | 0 30 | i j get if 1 or then 31 | j height 1 - < if 32 | i j 1 + get if 2 or then 33 | j height 2 - < if 34 | i j 2 + get if 4 or then 35 | j height 3 - < if 36 | i j 3 + get if 8 or then 37 | j height 4 - < if 38 | i j 4 + get if 16 or then 39 | j height 5 - < if 40 | i j 5 + get if 32 or then 41 | then 42 | then 43 | then 44 | then 45 | then 46 | 63 + emit 47 | loop 48 | [char] - emit 49 | 6 +loop 50 | esc emit [char] \ emit cr ; 51 | 52 | \ : show show-sixel ; \ replace `show` 53 | : show show-sixel-tiny ; \ replace `show` 54 | -------------------------------------------------------------------------------- /hardware/register_v0/turtle-fixed-point.f: -------------------------------------------------------------------------------- 1 | ( turtle graphics ) 2 | ( requires: pixels-adapter.f pixels.f ) 3 | 4 | here 5 | 255 c, 255 c, 255 c, 255 c, 254 c, 254 c, 254 c, 253 c, 253 c, 252 c, 6 | 251 c, 250 c, 249 c, 248 c, 247 c, 246 c, 245 c, 244 c, 242 c, 241 c, 7 | 240 c, 238 c, 236 c, 235 c, 233 c, 231 c, 229 c, 227 c, 225 c, 223 c, 8 | 221 c, 218 c, 216 c, 214 c, 211 c, 209 c, 206 c, 203 c, 201 c, 198 c, 9 | 195 c, 192 c, 189 c, 186 c, 183 c, 180 c, 177 c, 174 c, 170 c, 167 c, 10 | 164 c, 160 c, 157 c, 153 c, 149 c, 146 c, 142 c, 138 c, 135 c, 131 c, 11 | 127 c, 123 c, 119 c, 115 c, 111 c, 107 c, 103 c, 99 c, 95 c, 91 c, 12 | 87 c, 82 c, 78 c, 74 c, 70 c, 65 c, 61 c, 57 c, 52 c, 48 c, 13 | 43 c, 39 c, 35 c, 30 c, 26 c, 21 c, 17 c, 12 c, 8 c, 3 c, 0 c, ( TODO <-- should be -1 ) 14 | constant table 15 | table . 16 | : cos 17 | abs 360 mod dup 180 >= if 18 | 360 swap - 19 | then 20 | dup 90 >= if 21 | -1 180 rot - 22 | else 23 | 1 swap 24 | then 25 | table + c@ 1 + * 26 | ; 27 | 28 | : sin 90 - cos ; 29 | 30 | variable x variable y variable theta 31 | variable dx variable dy 32 | 33 | : point-x x @ 256 / width 2 / + ; 34 | : point-y y @ 256 / height 2 / + ; 35 | : valid-x? point-x 0 width 1 - within ; 36 | : valid-y? point-y 0 height 1 - within ; 37 | : valid? valid-x? valid-y? and ; 38 | : plot valid? if point-x point-y set then ; 39 | 40 | : go 256 * y ! 256 * x ! ; 41 | : head dup theta ! dup cos dx ! sin dy ! ; 42 | : pose head go ; 43 | 44 | : start clear 0 0 0 pose ; 45 | : turn theta @ + head ; 46 | : move 0 do dx @ x +! dy @ y +! plot loop ; 47 | : jump dup dx @ * x +! dy @ * y +! ; 48 | -------------------------------------------------------------------------------- /hardware/register/assembler.fs: -------------------------------------------------------------------------------- 1 | require ../shared/memory.fs 2 | 3 | false warnings ! \ redefining gforth words 4 | 5 | : here h @ memory - ; 6 | : c, ( c -- ) h @ c! 1 h +! ; 7 | : , ( cc -- ) dup c, 8 rshift c, ; 8 | : s! ( val addr -- ) memory + over 8 rshift over 1+ c! c! ; 9 | : s@ ( addr -- val ) memory + dup c@ swap 1+ c@ 8 lshift or ; 10 | 11 | true warnings ! 12 | 13 | : 2nybbles, ( x i -- ) 4 lshift or c, ; 14 | : 4nybbles, ( z y x i -- ) 2nybbles, 2nybbles, ; 15 | 16 | : halt, ( x -- ) 0 2nybbles, ; 17 | : add, ( z y x -- ) 1 4nybbles, ; 18 | : sub, ( z y x -- ) 2 4nybbles, ; 19 | : mul, ( z y x -- ) 3 4nybbles, ; 20 | : div, ( z y x -- ) 4 4nybbles, ; 21 | : nand, ( z y x -- ) 5 4nybbles, ; 22 | : shl, ( z y x -- ) 6 4nybbles, ; 23 | : shr, ( z y x -- ) 7 4nybbles, ; 24 | : in, ( y x -- ) 8 2nybbles, ; 25 | : out, ( y x -- ) 9 2nybbles, ; 26 | : read, ( z y x -- ) 10 4nybbles, ; 27 | : write, ( z y x -- ) 11 4nybbles, ; 28 | : ld16+, ( z y x -- ) 12 4nybbles, ; 29 | : st16+, ( z y x -- ) 13 4nybbles, ; 30 | : lit8, ( v x -- ) 14 2nybbles, c, ; 31 | : cp?, ( z y x -- ) 15 4nybbles, ; 32 | 33 | 0 constant pc 34 | 1 constant zero 35 | 36 | : cp, ( y x -- ) zero cp?, ; 37 | : ld16, ( y x -- ) zero ld16+, ; 38 | : st16, ( y x -- ) zero st16+, ; 39 | 40 | : jump, ( addr -- ) pc pc ld16, , ; 41 | 42 | : not, ( y x -- ) dup nand, ; 43 | : and, 2 pick -rot nand, dup not, ; 44 | : or, ( z y x -- ) dup dup not, over dup not, nand, ; 45 | 46 | : label ( -- addr ) here constant ; 47 | : skip, ( -- dest ) 0 jump, here 2 - ; 48 | : start, ( orig -- ) here swap s! ; 49 | 50 | : write-boot-block ( -- ) 0 0 here write-block ; \ note: depends on redefined `here` 51 | -------------------------------------------------------------------------------- /notes/nybbleforth.md: -------------------------------------------------------------------------------- 1 | # [nybbleForth](https://github.com/larsbrinkhoff/nybbleForth) 2 | 3 | Very minimalist defintions 4 | 5 | : >mark here ; 6 | : >resolve here over - swap 1- c! ; 7 | 8 | : begin, 0insn here ; 9 | : again, 0 lit, 0branch, ; 10 | : ahead, 0 again, >mark ; 11 | : then, 0insn >resolve ; 12 | 13 | : if, 0 0branch, >mark 0insn ; 14 | : until, 0branch, ; 15 | 16 | : else, ahead, swap then, ; 17 | : while, swap if, ; 18 | : repeat, again, then, ; 19 | 20 | : drop if then ; / weird! 21 | : 2drop + drop ; / weird! 22 | 23 | variable temp 24 | : swap >r temp ! r> temp @ ; 25 | : over >r temp ! temp @ r> temp @ ; 26 | : rot >r swap r> swap ; 27 | 28 | : r@ r> temp ! temp @ >r temp @ ; 29 | : 2>r r> swap rot >r >r >r ; 30 | : 2r> r> r> r> rot >r swap ; 31 | 32 | : dup temp ! temp @ temp @ ; 33 | : 2dup over over ; 34 | : ?dup temp ! temp @ if temp @ temp @ then ; 35 | 36 | : nip >r temp ! r> ; 37 | 38 | : invert -1 nand ; 39 | : negate invert 1 + ; 40 | : - negate + ; 41 | 42 | : 1+ 1 + ; 43 | : 1- -1 + ; 44 | : +! dup >r @ + r> ! ; 45 | : 0= if 0 else -1 then ; 46 | : = - 0= ; 47 | : <> = 0= ; 48 | 49 | : execute >r ; 50 | 51 | : 0< [ 1 cell 8 * 1 - lshift ] literal nand invert if -1 else 0 then ; 52 | : or invert swap invert nand ; 53 | : xor 2dup nand 1+ dup + + + ; 54 | : and nand invert ; 55 | : 2* dup + ; 56 | 57 | : < 2dup xor 0< if drop 0< else - 0< then ; 58 | : u< 2dup xor 0< if nip 0< else - 0< then ; 59 | : > swap < ; 60 | : u> swap u> ; 61 | 62 | : c@ @ 255 and ; 63 | : c! dup >r @ 65280 and + r> ! ; 64 | 65 | create rstack rsize allot 66 | variable rp 67 | : @rp rp @ ; 68 | : 0rp rstack rsize + rp ! ; -------------------------------------------------------------------------------- /library/turtle/test.f: -------------------------------------------------------------------------------- 1 | ( test turtle graphics ) 2 | ( requires: prelude pixels turtle ) 3 | 4 | : angle 360 swap / ; 5 | : draw -rot 0 do 2dup move turn loop 2drop ; 6 | : polygon dup angle draw ; 7 | 8 | : triangle 3 polygon ; 9 | : square 4 polygon ; 10 | : pentagon 5 polygon ; 11 | : hexagon 6 polygon ; 12 | : circle 36 polygon ; 13 | 14 | : shapes start 0 -70 go 50 hexagon 50 pentagon 50 square 50 triangle show ; 15 | 16 | : star 5 144 draw ; 17 | 18 | : spin dup angle swap 0 do 2dup turn call loop 2drop ; 19 | : stars start [: 80 star :] 3 spin show ; 20 | 21 | : spiro start [: 4 circle :] 15 spin show ; 22 | 23 | : burst start 60 0 do i 6 * head 0 0 go 80 move loop show ; 24 | 25 | : squaral start -70 -35 go 20 0 do 140 move 126 turn loop show ; 26 | 27 | : rose start 0 54 0 do 2 + dup move 84 turn loop show ; 28 | 29 | : arc 0 do 2dup turn move loop 2drop ; 30 | : petal 2 0 do 4 6 16 arc 1 -6 16 arc 180 turn loop ; 31 | : flower start [: petal :] 15 spin show ; ( TODO ' petal instead of [: petal :] ) 32 | 33 | : spiral-rec 1 + dup move 92 turn dup 110 < if recurse then ; 34 | : spiral start 1 spiral-rec show ; 35 | 36 | : demo burst shapes squaral spiro stars rose flower spiral ; 37 | demo 38 | 39 | ( 40 | variable 'koch 41 | : curve dup 0 > if 2dup 1 - swap 3 / swap 'koch @ execute else drop move then ; 42 | : koch 2dup curve -60 turn 2dup curve 120 turn 2dup curve -60 turn 2dup curve 2drop ; 43 | ' koch 'koch ! 44 | 45 | start 46 | -80 0 go 47 | 50 1 curve 48 | show 49 | 50 | start 51 | -80 0 go 52 | 100 2 curve 53 | show 54 | 55 | start 56 | -80 0 go 57 | 200 3 curve 58 | show 59 | 60 | start 61 | -80 0 go 62 | 400 4 curve 63 | show 64 | 65 | : snowflake 3 0 do 2dup curve 120 turn loop 2drop ; 66 | 67 | start 68 | -80 0 go 69 | 80 0 snowflake 70 | show 71 | 72 | start 73 | -80 0 go 74 | 50 1 snowflake 75 | show 76 | 77 | start 78 | -80 0 go 79 | 50 2 snowflake 80 | show 81 | ) -------------------------------------------------------------------------------- /hardware/register/machine.c: -------------------------------------------------------------------------------- 1 | #include "../shared/memory.c" 2 | 3 | unsigned short reg[0x10]; 4 | 5 | #define NEXT mem[reg[0]++] 6 | #define LOW(b) b & 0x0F 7 | #define HIGH(b) LOW(b >> 4) 8 | 9 | int main(void) { 10 | readBlock(0, 0, sizeof(mem)); 11 | while (1) { 12 | unsigned char c = NEXT; 13 | unsigned char i = HIGH(c); 14 | unsigned char x = LOW(c); 15 | switch(i) { 16 | case 0: return reg[x]; // HALT 17 | case 8: reg[x] = getc(stdin); break; // IN 18 | case 9: putc(reg[x], stdout); break; // OUT 19 | case 14: reg[x] = (signed char)NEXT; break; // LIT8 20 | default: // instructions that need a second byte 21 | unsigned char j = NEXT; 22 | unsigned char y = HIGH(j); 23 | unsigned char z = LOW(j); 24 | switch(i) { 25 | case 1: reg[z] = reg[y] + reg[x]; break; // ADD 26 | case 2: reg[z] = reg[y] - reg[x]; break; // SUB 27 | case 3: reg[z] = reg[y] * reg[x]; break; // MUL 28 | case 4: reg[z] = reg[y] / reg[x]; break; // DIV 29 | case 5: reg[z] = ~(reg[y] & reg[x]); break; // NAND 30 | case 6: reg[z] = reg[y] << reg[x]; break; // SHL 31 | case 7: reg[z] = (unsigned short)reg[y] >> reg[x]; break; // SHR (logical) 32 | case 10: readBlock(reg[z], reg[y], reg[x]); break; // READ 33 | case 11: writeBlock(reg[z], reg[y], reg[x]); break; // WRITE 34 | case 12: reg[z] = mem[reg[y]] | (mem[reg[y] + 1] << 8); reg[y] += reg[x]; break; // LD16+ 35 | case 13: // ST16+ 36 | mem[reg[y]] = reg[z] & 0xFF; 37 | mem[reg[y] + 1] = reg[z] >> 8; 38 | reg[y] += reg[x]; 39 | break; 40 | case 15: if (reg[x] == 0) reg[z] = reg[y]; break; // CP? 41 | default: printf("Invalid instruction! (%i)\n", i); return 1; 42 | } 43 | } 44 | } 45 | } -------------------------------------------------------------------------------- /hardware/register/machine.fs: -------------------------------------------------------------------------------- 1 | require ../shared/memory.fs 2 | 3 | create registers 16 cells allot 4 | registers 16 cells erase 5 | 6 | : 32bit ( n -- n32 ) dup 15 rshift 0<> if -1 16 lshift or then ; 7 | : 16bit ( n -- n16 ) $ffff and ; 8 | : reg ( i -- addr ) cells registers + ; 9 | : reg+! ( v reg -- ) swap @ over +! dup @ 16bit swap ! ; 10 | : fetch-pc registers @ memory + c@ 1 registers +! ; 11 | : nybbles ( byte -- n2 n1 ) dup $f and swap 4 rshift ; 12 | : xyz ( x -- reg-x reg-y reg-z ) reg fetch-pc nybbles reg swap reg ; 13 | : binop ( x op -- ) swap xyz >r @ 32bit swap @ 32bit rot execute 16bit r> ! ; 14 | 15 | : nand and invert ; 16 | : shr swap 16bit swap rshift ; 17 | 18 | : step ( -- ) fetch-pc nybbles 19 | case 20 | 0 of reg @ (bye) endof \ HALT 21 | 1 of ['] + binop endof \ ADD 22 | 2 of ['] - binop endof \ SUB 23 | 3 of ['] * binop endof \ MUL 24 | 4 of ['] / binop endof \ DIV 25 | 5 of ['] nand binop endof \ NAND 26 | 6 of ['] lshift binop endof \ SHL 27 | 7 of ['] shr binop endof \ SHR 28 | 8 of stdin key-file swap reg ! endof \ IN 29 | 9 of reg @ emit endof \ OUT 30 | 10 of xyz @ swap @ rot @ read-block endof \ READ 31 | 11 of xyz @ swap @ rot @ write-block endof \ WRITE 32 | 12 of xyz over @ s@ swap ! reg+! endof \ LD+ 33 | 13 of xyz @ over @ s! reg+! endof \ ST+ 34 | 14 of fetch-pc dup $80 and if $ff00 or then swap reg ! endof \ LDC 35 | 15 of xyz rot @ 0= if swap @ swap ! else 2drop then endof \ CP? 36 | throw 37 | endcase ; 38 | 39 | : steps ( n -- ) 0 do step loop ; 40 | : run ( -- ) begin step again ; 41 | 42 | : soft-reset ( -- ) registers 16 cells erase ; 43 | : hard-reset ( -- ) soft-reset memory memory-size erase memory h ! ; 44 | : reboot ( -- ) hard-reset read-boot-block run ; -------------------------------------------------------------------------------- /hardware/stack/disassemble.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | void disassemble(short c) { 4 | printf("%x: ", c); 5 | c = (c & 0xff) << 8 | ((c & 0xff00) >> 8); 6 | if ((c & 1) == 0) { // call? 7 | printf("CALL[%x] ", c); 8 | } else { // instructions 9 | for (short slot = 0; slot < 15; slot += 5) { 10 | short i = (c >> (11 - slot)) & 0x1F; 11 | switch (i) { 12 | case 0: printf("halt "); break; 13 | case 1: printf("add "); break; 14 | case 2: printf("sub "); break; 15 | case 3: printf("mul "); break; 16 | case 4: printf("div "); break; 17 | case 5: printf("not "); break; 18 | case 6: printf("and "); break; 19 | case 7: printf("or "); break; 20 | case 8: printf("xor "); break; 21 | case 9: printf("shl "); break; 22 | case 10: printf("shr "); break; 23 | case 11: printf("in "); break; 24 | case 12: printf("out "); break; 25 | case 13: printf("read "); break; 26 | case 14: printf("write "); break; 27 | case 15: printf("ld16+ "); break; 28 | case 16: printf("ld8+ "); break; 29 | case 17: printf("st16+ "); break; 30 | case 18: printf("st8+ "); break; 31 | case 19: printf("lit16 "); break; 32 | case 20: printf("lit8 "); break; 33 | case 21: printf("0jump "); break; 34 | case 22: printf("next "); break; 35 | case 23: printf("drop "); break; 36 | case 24: printf("dup "); break; 37 | case 25: printf("over "); break; 38 | case 26: printf("swap "); break; 39 | case 27: printf("push "); break; 40 | case 28: printf("pop "); break; 41 | case 29: printf("peek "); break; 42 | case 30: printf("ret "); break; 43 | case 31: printf("nop "); break; 44 | } 45 | } 46 | } 47 | printf("\n"); 48 | } 49 | 50 | int main(void) { 51 | disassemble(0x3DA5); 52 | disassemble(0x001E); 53 | } -------------------------------------------------------------------------------- /readme.md: -------------------------------------------------------------------------------- 1 | # Forthkit 2 | 3 | Inspired by [Lispkit](https://github.com/AshleyF/Lispkit), build your own Forth from scratch. 4 | 5 | 0) Learn what Forth is by building a pixel library and turtle graphics in gforth 6 | * Write a [console Pixel library](./library/pixels/) using Unicode Braille characters 7 | * Use this to do [turtle graphics](./library/turtle/) 8 | 2) Make [register-based "hardware"](./hardware/register/) (VM in Forth) and [assembler](./hardware/register/assembler.fs) 9 | 3) Use the assembler to [build a kernel](./hardware/register/kernel.fs) (and boot image) 10 | 4) Rewrite the VM in C and abandon gforth 11 | 5) TODO: [Bootstrap](./hardware/register/bootstrap.fs) the rest of the language 12 | * TODO: [Port pixel library](./hardware/register/pixels-adapter.fs) 13 | * TODO: [Port turtle graphics](./hardware/register/turtle-fixed-point.fs) (using fixed point) 14 | * TODO: [Port kernel itself](./hardware/register/kernel-adapter.fs) 15 | * TODO: Achieve meta-circularity! That is, build the kernel using gforth, then use that kernel to build a new (identical for now) kernel. Iterate. 16 | * TODO: Re-write kernel in more natural Forth syntax 17 | 5) TODO: Build an inner interpreter and replace calls 18 | * TODO: Experiment with direct/indirect threading 19 | * TODO: Experiment with using the return stack for locals and loop counters 20 | * TODO: Implement remaining Forth control structures 21 | * TODO: Explain `does>` in the context of direct/indirect threading 22 | * TODO: Discuss/implement token threading 23 | * TODO: Discuss separate headers (e.g. fall-through definitions, save memory, ...) 24 | * TODO: Discuss separate host/target (like Brief) 25 | 6) TODO: Make more new "hardware" - a stack machine this time 26 | 7) TODO: Port our Forth to this - see how the inner interpreter goes away 27 | * TODO: Use block-style disk I/O 28 | 8) TODO: Move to a colorForth style variant (less syntax, no immediate words, etc.) 29 | 9) TODO: Build a block editor and stop using Vim 30 | * TODO: We've now bootstrapped a whole "OS" for ourselves! 31 | 10) TODO: Discuss non-standard ideas: 32 | * Quotations (`[:` ... `:]`), combinators, (Factor, Joy, Brief, ...) 33 | * `if` as a combinator 34 | * Recursion as only control flow 35 | 11) TODO: Discuss other execution models (e.g. stack/continuation, XY, Brief, ...) 36 | 12) TODO: More ideas 37 | * VT100 library 38 | * Snake game 39 | * Tetris game 40 | * Discuss optimizing compilation -------------------------------------------------------------------------------- /hardware/register_v2/machine-test.fs: -------------------------------------------------------------------------------- 1 | require machine.fs 2 | 3 | 2 constant x 4 | 3 constant y 5 | 4 constant z 6 | 7 | hard-reset ." Test ldc " 8 | 42 x ldc, 9 | step 10 | x reg @ 42 = . cr 11 | 12 | hard-reset ." Test ld+ " 13 | 42 100 s! 14 | 5 x ldc, 15 | 100 y ldc, 16 | z y x ld+, 17 | 3 steps 18 | z reg @ 42 = y reg @ 105 = and . cr 19 | 20 | hard-reset ." Test st+ " 21 | 5 x ldc, 22 | 100 y ldc, 23 | 42 z ldc, 24 | z y x st+, 25 | 4 steps 26 | 100 s@ 42 = y reg @ 105 = and . cr 27 | 28 | hard-reset ." Test cp? zero " 29 | 0 x ldc, 30 | 42 y ldc, 31 | 100 z ldc, 32 | z y x cp?, 33 | 4 steps 34 | z reg @ 42 = . cr 35 | 36 | hard-reset ." Test cp? non-zero " 37 | 7 x ldc, 38 | 42 y ldc, 39 | 100 z ldc, 40 | z y x cp?, 41 | 4 steps 42 | z reg @ 100 = . cr 43 | 44 | hard-reset ." Test add " 45 | 7 x ldc, 46 | 42 y ldc, 47 | z y x add, 48 | 3 steps 49 | z reg @ 42 7 + = . cr 50 | 51 | hard-reset ." Test sub " 52 | 7 x ldc, 53 | 42 y ldc, 54 | z y x sub, 55 | 3 steps 56 | z reg @ 42 7 - = . cr 57 | 58 | hard-reset ." Test mul " 59 | 7 x ldc, 60 | 42 y ldc, 61 | z y x mul, 62 | 3 steps 63 | z reg @ 42 7 * = . cr 64 | 65 | hard-reset ." Test div " 66 | 10 x ldc, 67 | -20 y ldc, 68 | z y x div, 69 | 3 steps 70 | z reg @ -20 10 / $ffff and = . cr 71 | 72 | hard-reset ." Test nand " 73 | 7 x ldc, 74 | 42 y ldc, 75 | z y x nand, 76 | 3 steps 77 | z reg @ 42 7 and invert $ffff and = . cr 78 | 79 | hard-reset ." Test shl " 80 | 4 x ldc, 81 | 1 y ldc, 82 | z y x shl, 83 | 3 steps 84 | z reg @ 1 4 lshift = . cr 85 | 86 | hard-reset ." Test shr " 87 | 4 x ldc, 88 | -7 y ldc, 89 | z y x shr, 90 | 3 steps 91 | z reg @ -7 64 16 4 - - rshift = . cr 92 | 93 | hard-reset ." Test in " 94 | x in, 95 | step 96 | x reg @ emit cr 97 | 98 | hard-reset ." Test out " 99 | 65 x ldc, 100 | x out, 101 | 2 steps cr 102 | 103 | hard-reset ." Test write " 104 | 1 x ldc, 105 | 2 y ldc, 106 | 3 z ldc, 107 | z y x write, 108 | 4 steps cr 109 | 110 | hard-reset ." Test read " 111 | 1 x ldc, 112 | 2 y ldc, 113 | 3 z ldc, 114 | z y x read, 115 | 4 steps cr 116 | 117 | hard-reset ." Test halt " 118 | 42 x ldc, 119 | x halt, 120 | 100 steps 121 | -------------------------------------------------------------------------------- /hardware/register_v0/snake.f: -------------------------------------------------------------------------------- 1 | ( snake game ) 2 | 3 | 32 constant blank 4 | 9632 constant square 5 | 9650 constant up 6 | 9664 constant left 7 | 9660 constant down 8 | 9654 constant right 9 | 11044 constant circle 10 | 11 | variable hx 40 hx ! 12 | variable hy 20 hy ! 13 | 14 | variable dx 0 dx ! 15 | variable dy 0 dy ! 16 | variable head up head ! 17 | 18 | variable tx 40 tx ! 19 | variable ty 20 ty ! 20 | 21 | variable len 8 len ! 22 | variable count 0 count ! 23 | 24 | 32768 constant rndmod 25 | 25173 constant rndmult 26 | 13849 constant rndinc 27 | 28 | variable rndseed 29 | 30 | : rand 31 | rndseed @ rndmult * rndinc + rndmod mod 32 | dup rndseed ! 33 | dup 8 2/ xor ( Add some bit mixing ) 34 | ; 35 | 36 | : init 37 | clear 38 | vtclear vthide 39 | vtblue vtblack vtcolors 40 | vtbright vtattrib 41 | ; 42 | 43 | : border 44 | 80 0 do square i 0 set square i 39 set loop 45 | 40 0 do square 0 i set square 79 i set loop 46 | ; 47 | 48 | : touching 49 | 2dup 1+ get blank <> if 1+ true else 50 | 2dup 1- get blank <> if 1- true else 51 | 2dup swap 1+ swap get blank <> if swap 1+ swap true else 52 | 2dup swap 1- swap get blank <> if swap 1- swap true else 53 | 2drop false 54 | then then then then 55 | ; 56 | 57 | : food 58 | rand 80 mod rand 40 mod 2dup 59 | touching if 2drop recurse 60 | else circle -rot set then 61 | ; 62 | 63 | variable speed 10 speed ! 64 | : delay speed @ 0 do 10000 0 do loop loop ; 65 | 66 | : snake 67 | square hx @ hy @ set ( make head into body ) 68 | hx @ dx @ + hx ! 69 | hy @ dy @ + hy ! 70 | count @ 1+ count ! 71 | hx @ hy @ get circle = if len @ 2 * len ! food speed @ 1- speed ! then ( eat food ) 72 | head @ hx @ hy @ set ( draw head ) 73 | ; 74 | 75 | : tail 76 | count @ len @ >= if 77 | count @ 1- count ! 78 | blank tx @ ty @ set ( erase tail ) 79 | tx @ ty @ touching if ( should always be true! ) 80 | ty ! tx ! ( make new tail ) 81 | then 82 | then 83 | ; 84 | 85 | : input 86 | key 87 | dup char x = if halt else 88 | dup char w = if 0 dx ! -1 dy ! up head ! else 89 | dup char a = if -1 dx ! 0 dy ! left head ! else 90 | dup char r = if 0 dx ! 1 dy ! down head ! else 91 | dup char s = if 1 dx ! 0 dy ! right head ! else 92 | then then then then then drop 93 | dx @ dy @ or 0 <> if 94 | snake tail update delay 95 | then 96 | recurse-tail 97 | ; 98 | 99 | : start init border update vtgreen vtfg food update input ; 100 | 101 | start 102 | -------------------------------------------------------------------------------- /hardware/register_v2/debugger.fs: -------------------------------------------------------------------------------- 1 | require machine.fs 2 | require kernel.fs 3 | 4 | : dump-registers ( -- ) registers 16 cells dump ; 5 | : dump-memory ( -- ) memory memory-size dump ; 6 | : dump-stacks ( -- ) d reg @ r reg @ min dup memory + memory-size rot - dump ; 7 | 8 | : run-word ( addr -- ) pc reg ! run ; 9 | : rw run-word ; 10 | 11 | here . ." byte kernel" cr 12 | 13 | \ label 'dot 14 | \ x popd, 15 | \ 48 y ldc, 16 | \ x x y add, 17 | \ x out, 18 | \ ret, 19 | 20 | label 'hello 21 | ' here call, 22 | 104 literal, \ h 23 | ' c, call, 24 | 101 literal, \ e 25 | ' c, call, 26 | 108 literal, \ l 27 | ' c, call, 28 | 108 literal, \ l 29 | ' c, call, 30 | 111 literal, \ o 31 | ' c, call, 32 | 5 literal, \ length 33 | ' type call, 34 | ' bye call, 35 | 36 | label 'parse 37 | ' refill call, 38 | ' drop call, 39 | ' parse-name call, 40 | ' cr call, 41 | ' cr call, 42 | ' 2dup call, 43 | ' u. call, 44 | ' u. call, 45 | ' >in call, 46 | ' @ call, 47 | ' u. call, 48 | ' type call, 49 | ' parse-name call, 50 | ' cr call, 51 | ' cr call, 52 | ' 2dup call, 53 | ' u. call, 54 | ' u. call, 55 | ' >in call, 56 | ' @ call, 57 | ' u. call, 58 | ' type call, 59 | ' bye call, 60 | 61 | 62 | label 'test 63 | 7 literal, 64 | 42 literal, 65 | ' refill call, 66 | ' drop call, 67 | 0 literal, 68 | ' parse-name call, 69 | ' >number call, 70 | ' 2drop call, 71 | 0 literal, 72 | ' parse-name call, 73 | ' >number call, 74 | ' 2drop call, 75 | ' ' call, 76 | ' execute call, 77 | ' ' call, 78 | ' execute call, 79 | ' ' call, 80 | ' execute call, 81 | ' ' call, 82 | ' execute call, 83 | ' ' call, 84 | ' execute call, 85 | ' bye call, 86 | 87 | label 'go 88 | ' quit call, 89 | ' bye call, 90 | 91 | label 'loop 92 | 0 literal, 93 | 3 literal, 94 | ?do, 95 | ' i call, 96 | ' . call, 97 | ' cr call, 98 | loop, 99 | ' bye call, 100 | 101 | run 102 | -------------------------------------------------------------------------------- /notes/todo.md: -------------------------------------------------------------------------------- 1 | - [`UM*`](https://forth-standard.org/standard/core/UMTimes) 2 | - [`UM/MOD`](https://forth-standard.org/standard/core/UMDivMOD) 3 | - [`*/`](https://forth-standard.org/standard/core/TimesDiv) 4 | - [`*/MOD`](https://forth-standard.org/standard/core/TimesDivMOD) 5 | - [`FM/MOD`](https://forth-standard.org/standard/core/FMDivMOD) 6 | - [`M*`](https://forth-standard.org/standard/core/MTimes) 7 | - [`SM/REM`](https://forth-standard.org/standard/core/SMDivREM) 8 | - [`ENVIRONMENT?`](https://forth-standard.org/standard/core/ENVIRONMENTq) 9 | 10 | - [`ROLL`](https://forth-standard.org/standard/core/ROLL) (extension) 11 | - [`.R`](https://forth-standard.org/standard/core/DotR) (extension) (swap dup 0< if negate 1 swap rot 1- else 0 swap rot then swap dup uwidth rot swap - spaces swap if '-' emit then u.) 12 | - [`U.R`](https://forth-standard.org/standard/core/UDotR) (extension) (swap dup uwidth rot swap - spaces u.) 13 | - [`[COMPILE]`](https://forth-standard.org/standard/core/BracketCOMPILE) (extension) (immediate word find >cfa ,) 14 | - [`COMPILE,`](https://forth-standard.org/standard/core/COMPILEComma) (extension) 15 | - [`:NONAME`](https://forth-standard.org/standard/core/ColonNONAME) (extension) (0 0 create here @ docol , ]) 16 | - [`ACTION-OF`](https://forth-standard.org/standard/core/ACTION-OF) (extension) 17 | - [`CASE`](https://forth-standard.org/standard/core/CASE) (extension) (immediate 0) 18 | - [`OF`](https://forth-standard.org/standard/core/OF) (extension) (immediate ' over , ' = , [compile] if ' drop ,) 19 | - [`ENDOF`](https://forth-standard.org/standard/core/ENDOF) (extension) (immediate [compile] else) 20 | - [`ENDCASE`](https://forth-standard.org/standard/core/ENDCASE) (extension) (immediate ' drop , begin ?dup while [compile] then repeat) 21 | - [`DEFER`](https://forth-standard.org/standard/core/DEFER) (extension) 22 | - [`DEFER!`](https://forth-standard.org/standard/core/DEFERStore) (extension) 23 | - [`DEFER@`](https://forth-standard.org/standard/core/DEFERFetch) (extension) 24 | - [`IS`](https://forth-standard.org/standard/core/IS) (extension) 25 | - [`MARKER`](https://forth-standard.org/standard/core/MARKER) (extension) 26 | - [`REFILL`](https://forth-standard.org/standard/core/REFILL) (extension) 27 | - [`RESTORE-INPUT`](https://forth-standard.org/standard/core/RESTORE-INPUT) (extension) 28 | - [`S\"`](https://forth-standard.org/standard/core/Seq) (extension) 29 | - [`SAVE-INPUT`](https://forth-standard.org/standard/core/SAVE-INPUT) (extension) 30 | - [`TO`](https://forth-standard.org/standard/core/TO) (extension) (immediate word find >dfa 4+ state @ if ' lit , , ' ! , else ! then) 31 | - [`VALUE`](https://forth-standard.org/standard/core/VALUE) (extension) (word create docol , ' lit , , ' exit ,) 32 | 33 | - Optimize ; return call/jump -------------------------------------------------------------------------------- /notes/notes.md: -------------------------------------------------------------------------------- 1 | # Notes 2 | 3 | ## Bugs 4 | 5 | - Can't define words in terms of prior versions (infinite recursion!) 6 | - Machine build seems to not work on Mac (clang compiler) 7 | - u. doesn't work for signed values 8 | - Need to rationalize signed/unsigned behavior in general 9 | 10 | ## Bootstrapping 11 | 12 | - Make dot word (`.`) -- even simple single-digit 13 | - Make `header` word (at least input) 14 | - Do number parsing and echo 15 | - Make `find` word and search dictionary 16 | - Make `execute` word and, well, execute words 17 | - Add `state` word 18 | - Compile/push numbers depending on `state` 19 | - Start with pushing numbers (`: foo 42 ;`) 20 | - Compile/execute words depending on `state` and immediate flag 21 | - Make `create` and `immediate` 22 | - Make colon (`:`) and semicolon (`;`) 23 | - Away you go! 24 | 25 | ## Learnings 26 | 27 | - Building a VM in Forth makes debugging *much* easier 28 | - Stacks that maintain a pointer to the top are useful (move/push rather than push/move) 29 | - Tricky! `bl word find` stomps parsed word and finds "find" when interpreted! (fine compiled) 30 | - Making code relocatable with relative jumps would be useful! 31 | - Writing the outer interpreter in assembly is easier to get started than with standard words 32 | - Making the machine too primitive (e.g. 16 instructions) leads to bloat 33 | - Machine in Forth (rather than C) is much easier to debug 34 | - Can conditionally comment out with `if postpone \ then` (see `IFFLOORED`/`IFSYM` in tests) 35 | 36 | ## Koans 37 | 38 | - `create mybuffer 100 allot` (instead `100 buffer: mybuffer`) 39 | 40 | ## Pick 41 | 42 | ```forth 43 | : pick ( xu...x1 x0 u -- xu...x1 x0 xu ) 44 | dup 0= if drop dup exit then swap >r 1- recurse r> swap 45 | ; 46 | ``` 47 | 48 | Remove u. Copy the xu to the top of the stack. An ambiguous condition exists if there are less than u+2 items on the stack before PICK is executed. 49 | 50 | - `: dup 0 pick ;` 51 | - `: over 1 pick ;` 52 | 53 | ## If/Else/Then 54 | 55 | ```forth 56 | : if, 0branch, ; ( compile branch if TOS is 0, push address of branch address ) 57 | : then, here swap ! ; ( patch previous branch to here ) 58 | : else, branch, swap then, ; ( patch previous branch to here and start unconditional branch over false condition ) 59 | ``` 60 | 61 | ## Books 62 | 63 | - Dr. Ting's [Systems Guide to figForth](https://www.forth.org/OffeteStore/1010_SystemsGuideToFigForth.pdf) 64 | 65 | ## Links 66 | 67 | - [The Evolution of Forth](https://www.forth.com/resources/forth-programming-language/) 68 | - A little [treasure trove](https://www.complang.tuwien.ac.at/projects/forth.html) 69 | - [The FORTH Approach to Operating Systems](https://dl.acm.org/doi/pdf/10.1145/800191.805586) -------------------------------------------------------------------------------- /hardware/register_v0/assembler.f: -------------------------------------------------------------------------------- 1 | ( assembler for register VM ) 2 | 3 | variable dp ( dictionary pointer ) 4 | : here dp @ ; 5 | : , here ! here 2 + dp ! ; ( append ) 6 | : c, here c! here 1 + dp ! ; ( append byte ) 7 | 8 | : halt, 0 c, ; ( halt, → halt machine ) 9 | : ldc, 1 c, , c, ; ( x v ldc, → x = v ) 10 | : ld, 2 c, c, c, ; ( a x ld, → x = mem[a] ) 11 | : st, 3 c, c, c, ; ( x a st, → mem[a] = x ) 12 | : ldb, 4 c, c, c, ; ( a x ldb, → x = mem[a] ) 13 | : stb, 5 c, c, c, ; ( x a stb, → mem[a] = x ) 14 | : cp, 6 c, c, c, ; ( y x cp, → x = y ) 15 | : in, 7 c, c, ; ( x in, → x = getc ) 16 | : out, 8 c, c, ; ( x out, → putc x ) 17 | : inc, 9 c, c, c, ; ( y x inc, → x = y + 1 ) 18 | : dec, 10 c, c, c, ; ( y x dec, → x = y - 1 ) 19 | : add, 11 c, c, c, c, ; ( z y x add, → x = z + y ) 20 | : sub, 12 c, c, swap c, c, ; ( z y x sub, → x = z - y ) 21 | : mul, 13 c, c, c, c, ; ( z y x mul, → x = z × y ) 22 | : div, 14 c, c, swap c, c, ; ( z y x div, → x = z ÷ y ) 23 | : mod, 15 c, c, swap c, c, ; ( z y x mod, → x = z mod y ) 24 | : and, 16 c, c, c, c, ; ( z y x and, → x = z and y ) 25 | : or, 17 c, c, c, c, ; ( z y x or, → x = z or y ) 26 | : xor, 18 c, c, c, c, ; ( z y x xor, → x = z xor y ) 27 | : not, 19 c, c, c, ; ( y x not, → x = not y ) 28 | : shl, 20 c, c, swap c, c, ; ( z y x shl, → x = z << y ) 29 | : shr, 21 c, c, swap c, c, ; ( z y x shr, → x = z >> y ) 30 | : beq, 22 c, , c, c, ; ( x y a beq, → pc = a if x = y ) 31 | : bne, 23 c, , c, c, ; ( x y a bne, → pc = a if x ≠ y ) 32 | : bgt, 24 c, , swap c, c, ; ( x y a bgt, → pc = a if x > y ) 33 | : bge, 25 c, , swap c, c, ; ( x y a bge, → pc = a if x ≥ y ) 34 | : blt, 26 c, , swap c, c, ; ( x y a blt, → pc = a if x < y ) 35 | : ble, 27 c, , swap c, c, ; ( x y a ble, → pc = a if x ≤ y ) 36 | : jump, 28 c, , ; ( a jump, → pc = a ) 37 | : call, 29 c, , ; ( a call, → push[pc], pc = a ) 38 | : exec, 30 c, c, ; ( x exec, → pc = [x] ) 39 | : ret, 31 c, ; ( ret, → pc = pop[] ) 40 | : read, 32 c, c, c, c, ; ( a s b read, → block file to core ) 41 | : write, 33 c, c, c, c, ; ( a s b write, → core to block file ) 42 | 43 | : label here constant ; 44 | : ahead, here 1 + 0 jump, ; ( dummy jump, push address ) 45 | : continue, here swap m! ; ( patch jump TODO: why m! ? seems to need to avoid override in adapter ) 46 | 47 | : assemble 0 here 0 write halt ; 48 | -------------------------------------------------------------------------------- /hardware/register/machine-test.fs: -------------------------------------------------------------------------------- 1 | require machine.fs 2 | require assembler.fs 3 | 4 | 2 constant x 5 | 3 constant y 6 | 4 constant z 7 | 8 | hard-reset ." Test lit8 " 9 | 42 x lit8, 10 | step 11 | x reg @ 42 = . cr 12 | 13 | hard-reset ." Test ld16+ " 14 | 42 100 s! 15 | 5 x lit8, 16 | 100 y lit8, 17 | z y x ld16+, 18 | 3 steps 19 | z reg @ 42 = y reg @ 105 = and . cr 20 | 21 | hard-reset ." Test st16+ " 22 | 5 x lit8, 23 | 100 y lit8, 24 | 42 z lit8, 25 | z y x st16+, 26 | 4 steps 27 | 100 s@ 42 = y reg @ 105 = and . cr 28 | 29 | hard-reset ." Test cp? zero " 30 | 0 x lit8, 31 | 42 y lit8, 32 | 100 z lit8, 33 | z y x cp?, 34 | 4 steps 35 | z reg @ 42 = . cr 36 | 37 | hard-reset ." Test cp? non-zero " 38 | 7 x lit8, 39 | 42 y lit8, 40 | 100 z lit8, 41 | z y x cp?, 42 | 4 steps 43 | z reg @ 100 = . cr 44 | 45 | hard-reset ." Test add " 46 | 7 x lit8, 47 | 42 y lit8, 48 | z y x add, 49 | 3 steps 50 | z reg @ 42 7 + = . cr 51 | 52 | hard-reset ." Test sub " 53 | 7 x lit8, 54 | 42 y lit8, 55 | z y x sub, 56 | 3 steps 57 | z reg @ 42 7 - = . cr 58 | 59 | hard-reset ." Test mul " 60 | 7 x lit8, 61 | 42 y lit8, 62 | z y x mul, 63 | 3 steps 64 | z reg @ 42 7 * = . cr 65 | 66 | hard-reset ." Test div " 67 | 10 x lit8, 68 | -20 y lit8, 69 | z y x div, 70 | 3 steps 71 | z reg @ -20 10 / $ffff and = . cr 72 | 73 | hard-reset ." Test nand " 74 | 7 x lit8, 75 | 42 y lit8, 76 | z y x nand, 77 | 3 steps 78 | z reg @ 42 7 and invert $ffff and = . cr 79 | 80 | hard-reset ." Test shl " 81 | 4 x lit8, 82 | 1 y lit8, 83 | z y x shl, 84 | 3 steps 85 | z reg @ 1 4 lshift = . cr 86 | 87 | hard-reset ." Test shr " 88 | 4 x lit8, 89 | -7 y lit8, 90 | z y x shr, 91 | 3 steps 92 | z reg @ -7 64 16 4 - - rshift = . cr 93 | 94 | hard-reset ." Test in -- press a key: " 95 | x in, 96 | step 97 | x reg @ emit cr 98 | 99 | hard-reset ." Test out " 100 | 65 x lit8, 101 | x out, 102 | 2 steps 103 | ." (should print A)" cr 104 | 105 | hard-reset ." Test write " 106 | 5 x lit8, 107 | 10 y lit8, 108 | 0 z lit8, 109 | z y x write, 110 | memory 10 + h ! \ poke Hello into memory[10] 111 | 'H' c, 112 | 'e' c, 113 | 'l' c, 114 | 'l' c, 115 | 'o' c, 116 | 4 steps ." (confirmed by read)" cr 117 | 118 | hard-reset ." Test read " 119 | 5 x lit8, 120 | 20 y lit8, 121 | 0 z lit8, 122 | z y x read, 123 | 4 steps 124 | memory 20 + c@ 'H' = 125 | memory 21 + c@ 'e' = and 126 | memory 22 + c@ 'l' = and 127 | memory 23 + c@ 'l' = and 128 | memory 24 + c@ 'o' = and . cr 129 | 130 | hard-reset ." Test halt " 131 | 42 x lit8, 132 | x halt, 133 | 100 steps -------------------------------------------------------------------------------- /hardware/stack/bootstrap.fs: -------------------------------------------------------------------------------- 1 | header, : ] header, ] ; 2 | 3 | : halt, 0 slot, ; 4 | : add, 1 slot, ; 5 | : sub, 2 slot, ; 6 | : mul, 3 slot, ; 7 | : div, 4 slot, ; 8 | : not, 5 slot, ; 9 | : and, 6 slot, ; 10 | : or, 7 slot, ; 11 | : xor, 8 slot, ; 12 | : shl, 9 slot, ; 13 | : shr, 10 slot, ; 14 | : in, 11 slot, ; 15 | : out, 12 slot, ; 16 | : read, 13 slot, ; 17 | : write, 14 slot, ; 18 | : ld16+, 15 slot, ; 19 | : ld8+, 16 slot, ; 20 | : st16+, 17 slot, ; 21 | : st8+, 18 slot, ; 22 | : 0jump, 21 slot, here - c, ; 23 | : next, 22 slot, here swap - c, ; 24 | : drop, 23 slot, ; 25 | : dup, 24 slot, ; 26 | : over, 25 slot, ; 27 | : swap, 26 slot, ; 28 | : push, 27 slot, ; 29 | : pop, 28 slot, ; 30 | : peek, 29 slot, ; 31 | : nop, 31 slot, ; 32 | 33 | : (bye) [ halt, ] ; 34 | : bye 0 (bye) ; 35 | 36 | : + [ add, ] ; 37 | : * [ mul, ] ; 38 | : / [ div, ] ; 39 | 40 | : dup [ dup, ] ; 41 | : or [ or, ] ; 42 | 43 | : drop [ drop, ] ; 44 | : 2drop drop drop ; 45 | 46 | : dup [ dup, ] ; 47 | : over [ over, ] ; 48 | 49 | : >r [ push, ] ; 50 | : r> [ pop, ] ; 51 | : r@ [ peek, ] ; 52 | 53 | : immediate latest @ 2 + dup @ 128 or swap ! ; 54 | 55 | : \ 10 parse 2drop ; immediate 56 | 57 | \ now we can use comments like this 58 | 59 | : 1+ 1 + ; 60 | : 1- 1 - ; 61 | 62 | : invert [ not, ] ; \ ( x -- result ) invert bits 63 | : negate invert 1+ ; \ ( x -- result ) arithetic inverse (invert 1+) (0 swap -) 64 | : and [ and, ] ; 65 | : xor [ xor, ] ; 66 | : nand [ not, and, ] ; \ (non-standard) 67 | 68 | : rshift [ shr, ] ; 69 | : lshift [ shl, ] ; 70 | 71 | : key [ in, ] ; 72 | : emit [ out, ] ; 73 | 74 | : read-block [ read, ] ; \ ( file addr size -- ) block file of size -> address 75 | : write-block [ write, ] ; \ ( file addr size -- ) block file of size -> address 76 | 77 | : 0<> [ 0= invert ] ; \ ( y x -- b ) true if not equal to zero 78 | 79 | : hex 16 base ! ; \ ( -- ) set number-conversion radix to 16 80 | : octal 8 base ! ; \ ( -- ) set number-conversion radix to 8 (non-standard) 81 | : binary 2 base ! ; \ ( -- ) set number-conversion radix to 2 (non-standard) 82 | 83 | : 2* [ 1 shl, ] ; \ ( x -- result ) multiply by 2 (1 lshift) 84 | : 2/ [ 1 shr, ] ; \ ( x -- result ) divide by 2 (1 rshift) 85 | 86 | : abort [ quit ] ; \ TODO (clear-data) doesn't exist 87 | 88 | \ TODO : mod [ ] ; \ ( y x -- remainder ) remainder of division 89 | \ TODO : /mod [ ] ; \ ( y x -- remainder quotient ) remainder and quotient result of division 90 | \ TODO : ?dup [ ] ; \ ( x -- 0 | x x ) duplicate top stack value if non-zero 91 | \ TODO : 2swap [ ] ; \ ( w z y x -- y x w z ) swap top two pairs of stack values 92 | \ TODO : depth [ ] ; \ ( -- depth ) data stack depth \ TODO: why 8? 93 | 94 | here . 95 | -------------------------------------------------------------------------------- /hardware/register_v2/machine.fs: -------------------------------------------------------------------------------- 1 | require assembler.fs \ memory 2 | 3 | create registers 16 cells allot registers 16 cells erase 4 | 5 | : 32bit ( n -- n32 ) dup 15 rshift 0<> if -1 16 lshift or then ; 6 | : 16bit ( n -- n16 ) $ffff and ; 7 | : reg ( i -- addr ) cells registers + ; \ register address 8 | : reg+! ( v reg -- ) swap @ over +! dup @ 16bit swap ! ; \ +! while ensuring 16-bit 9 | : fetch-pc registers @ memory + c@ 1 registers +! ; \ fetch [pc++] 10 | : nybbles ( byte -- n2 n1 ) dup $f and swap 4 rshift ( $f and ) ; \ split byte into nybbles 11 | : xyz ( x -- reg-x reg-y reg-z ) reg fetch-pc nybbles reg swap reg ; 12 | : binop ( x op -- ) swap xyz >r @ 32bit swap @ 32bit rot execute 16bit r> ! ; \ execute binary operation ( y x -- ) 13 | 14 | \ [undefined] [: [if] 15 | \ : [: ( -- ) postpone ahead :noname ; immediate compile-only 16 | \ : ;] ( -- xt ) postpone ; ] postpone then latestxt postpone literal ; immediate compile-only 17 | \ [then] 18 | 19 | [undefined] [: [if] 20 | : nand and invert ; 21 | : shr swap 16bit swap rshift ; 22 | [then] 23 | 24 | : step ( -- ) fetch-pc nybbles \ fetch instruction 25 | case 26 | 0 of cr ." Halt " reg @ . quit endof \ halt(x) (halt with exit code x) 27 | 1 of fetch-pc dup $80 and if $ff00 or then swap reg ! endof \ ldc x=v (load constant signed byte into x) 28 | 2 of xyz over @ s@ swap ! reg+! endof \ ld+ z<-[y] y+=x (load from memory and inc/dec pointer) 29 | 3 of xyz @ over @ s! reg+! endof \ st+ z->[y] y+=x (store to memory and inc/dec pointer) 30 | 4 of xyz rot @ 0= if swap @ swap ! else 2drop then endof \ cp? z=y if x=0 (conditional copy) 31 | 5 of ['] + binop endof \ add z=y+x (addition) 32 | 6 of ['] - binop endof \ sub z=y-x (subtraction) 33 | 7 of ['] * binop endof \ mul z=y*x (multiplication) 34 | 8 of ['] / binop endof \ div z=y/x (division) 35 | [undefined] [: [if] 36 | 9 of ['] nand binop endof \ nand z=y nand x (not-and) 37 | [else] 38 | 9 of [: and invert ;] binop endof \ nand z=y nand x (not-and) 39 | [then] 40 | 10 of ['] lshift binop endof \ shl z=y<>x (bitwise shift-right) 43 | [else] 44 | 11 of [: swap 16bit swap rshift ;] binop endof \ shr z=y>>x (bitwise shift-right) 45 | [then] 46 | 12 of stdin key-file swap reg ! endof \ in x=getc() (read from console) 47 | 13 of reg @ emit endof \ out putc(x) (write to console) 48 | 14 of xyz @ swap @ rot @ read-block endof \ read(z,y,x) (file z of size y -> address x) 49 | 15 of xyz @ swap @ rot @ write-block endof \ write(z,y,x) (file z of size y <- address x) 50 | throw 51 | endcase ; 52 | : steps ( n -- ) 0 do step loop ; 53 | : run begin step again ; 54 | 55 | : soft-reset ( -- ) registers 16 cells erase ; \ reset registers, memory, h 56 | : hard-reset ( -- ) soft-reset memory memory-size erase memory h ! ; \ reset registers, memory, h 57 | : reboot ( -- ) hard-reset read-boot-block run ; \ reboot from block0 image -------------------------------------------------------------------------------- /hardware/stack/readme.md: -------------------------------------------------------------------------------- 1 | # Stack Machine 2 | 3 | ## Instruction Set 4 | 5 | 0. `HALT` - Halt execution 6 | 1. `ADD` - Addition 7 | 2. `SUB` - Subtraction 8 | 3. `MUL` - Multiplication 9 | 4. `DIV` - Division 10 | 5. `MOD` - Modulus 11 | 6. `NOT` - Bitwise not 12 | 7. `AND` - Bitwise and 13 | 8. `OR` - Bitwise or 14 | 9. `XOR` - Bitwise xor 15 | 10. `SHL` - Shift left 16 | 11. `SHR` - Shift right 17 | 12. `IN` - Input character 18 | 13. `OUT` - Output character 19 | 14. `READ` - Read block 20 | 15. `WRITE` - Write block 21 | 16. `LD16+` - Fetch cell at address, and increment over 22 | 17. `LD8+` - Fetch byte at address, and increment over 23 | 18. `ST16+` - Store cell at address, and increment over 24 | 19. `ST8+` - Store byte at address, and increment over 25 | 20. `LIT16` - Fetch literal next cell 26 | 20. `LIT8` - Fetch literal next signed byte 27 | 21. `0JUMP` - Jump to relative to offset in next byte if T = 0 28 | 22. `NEXT` - If R > 0, R-- and loop to next byte negative offset, otherwise drop R and continue 29 | 23. `DROP` - Drop top of stack 30 | 24. `DUP` - Duplicate top of stack 31 | 25. `OVER` - yx -> yxy 32 | 26. `SWAP` - yx -> xy 33 | 27. `PUSH` - Push top of data stack to return stack 34 | 28. `POP` - Pop top of return stack to data stack 35 | 29. `PEEK` - Peek top of return stack to data stack 36 | 30. `RET` - Return from call 37 | 31. `NOP` - No-op 38 | 39 | Other possibilities: `1+`, `1-`, `ROT`, `-ROT` `UNEXT`, ... 40 | 41 | ## Execution 42 | 43 | Code is aligned on 2-byte cells. 44 | 45 | - Fetch cell 46 | - If low bit is not set, call address 47 | - If next cell is `RET` (or last cell) then jump 48 | - Otherwise, process three 5-bit instructions in high bits 49 | - cell & 1111100000000000 >> 11 50 | - cell & 0000011111000000 >> 6 51 | - cell & 0000000000111110 >> 1 52 | - Program counter points to next cell 53 | - `LIT16`, `LIT8`, `0JUMP` and `NEXT` fetch next cell and advances 54 | - 16-element data and return stacks 55 | - Maybe implemented as T, S + 14 data and R + 15 return 56 | 57 | ## Notes 58 | 59 | - `LD` and `ST` do not increment 60 | - Calls must be even-numbered addresses, otherwise no alignment enforced 61 | - `literal,` goes away (becomes `lit16,`) [`: literal, x lit16, x pushd, ;`] 62 | - Actually, becomes "smart" compiling `lit8` or `lit16` 63 | - actually not, getting rit of `lit8` because it cause unaligned code 64 | 65 | ## Ideas 66 | 67 | - Calls with high bit set? (then jumps to zero-filled memory are not calls to 0000) 68 | - LD+ and ST+ instructions leave incremented address 69 | `swap ld+ rot st+` instead of `over @ over ! 1+ swap 1+ swap` 70 | - Plain fetch/store becomes: `ld+ nip`/`st+ nip` 71 | - Jump instruction? Otherwise [CALL] followed by [RET NOP NOP] 72 | - Inline definitions depending on current slot (use slots that would otherwise be no-ops) 73 | - 2 instructions: always better 74 | - 3 instructions: equivalent to call in worst case (maybe faster processing too) 75 | - 4 instructions: equivalent in last slot, better in second or first slot 76 | - 5 instructions: equivalent in second slot, better in first 77 | - 6 instructions: never better than call 78 | 79 | ## Simplifications 80 | 81 | - Stack pointers not exposed, so no `(clear-data)` or `(clear-return)` 82 | - No `source-addr`, `source-len`, `source` words 83 | 84 | ## TODO 85 | 86 | - `find-word` finds the *current* word (no smudge bit, recursion allowed, but not simple redefinition, not classic Forth) 87 | - `u<` 88 | \ u< ( y x -- b ) true if y less than x (- 0<) 89 | 0 header, u< 90 | over, ' sign-bit call, over, ' sign-bit call, sub, if, nip, ' sign-bit call, 1 literal, sub, not, else, ' < call, then, ret, 91 | -------------------------------------------------------------------------------- /notes/outer-interpreter.md: -------------------------------------------------------------------------------- 1 | # Outer Interpreter 2 | 3 | - Read 4 | - WORD: 5 | - skip-whitespace (<= 32) 6 | - apppend chars from input (key - skipping -1) 7 | - stop on whitespace 8 | - EVAL 9 | - search dictionary: 10 | - starting with latest 11 | - skip current if compiling (for redefinition) 12 | - compare: 13 | - remove immediate flag 14 | - compare lengths 15 | - compare characters 16 | - continues with next work if no match 17 | - not found if start of dictionary 18 | - if found: 19 | - execute (code field) if immediate or not compiling 20 | - otherwise compile call 21 | - if not found: 22 | - number? 23 | - if starts with '-', track sign (-1) 24 | - error if non-digit 25 | - print token followed by '?' 26 | - multiply by base (shift left digit) 27 | - add digit 28 | - continue until end 29 | - set sign (multiply) 30 | - push if not comiling, otherwise compile literal 31 | - PRINT ("ok"?) 32 | - LOOP 33 | 34 | ## Primitive Words 35 | 36 | - here 37 | - allot 38 | - word 39 | - create (at least header) 40 | - immediate 41 | - [ (compile) 42 | - ] (interactive) 43 | - ; (return - append ret, and interactive mode) 44 | - literal 45 | - , (comma) 46 | - c, (c-comma) 47 | - ' (tick) 48 | - ( (comment) 49 | - recurse (TCO?) 50 | - base (variable) 51 | 52 | ## Definitions 53 | 54 | : QUIT 55 | ( empty the return stack and set the input source to the user input device ) 56 | POSTPONE [ \ leave compilation 57 | REFILL 58 | WHILE 59 | ['] INTERPRET CATCH 60 | CASE 61 | 0 OF STATE @ 0= ( interpreting? ) IF ." OK" THEN CR ENDOF 62 | -1 OF ( Aborted ) ENDOF 63 | -2 OF ( display message from ABORT" ) ENDOF 64 | ( default ) DUP ." Exception # " . 65 | ENDCASE 66 | REPEAT BYE 67 | ; 68 | 69 | - QUIT Empty the return stack, store zero in SOURCE-ID if it is present, make the user input device the input source, and enter interpretation state. Do not display a message. Repeat the following: Accept a line from the input source into the input buffer, set >IN to zero, and interpret. Display the implementation-defined system prompt if in interpretation state, all processing has been completed, and no ambiguous condition exists. 70 | - POSTPONE Skip leading space delimiters. Parse name delimited by a space. Find name. Append the compilation semantics of name to the current definition. An ambiguous condition exists if name is not found. 71 | - [ Enter interpretation state. [ is an immediate word. 72 | - REFILL (-b) Attempt to fill the input buffer from the input source, returning a true flag if successful. When the input source is the user input device, attempt to receive input into the terminal input buffer. If successful, make the result the input buffer, set >IN to zero, and return true. Receipt of a line containing no characters is considered successful. If there is no input available from the current input source, return false. When the input source is a string from EVALUATE, return false and perform no other action. 73 | - ['] Skip leading space delimiters. Parse name delimited by a space. Find name. Append the run-time semantics given below to the current definition. 74 | - INTERPRET System-implementation word INTERPRET that embodies the text interpreter semantics 75 | - >IN (-a) a-addr is the address of a cell containing the offset in characters from the start of the input buffer to the start of the parse area. 76 | - ABORT Empty the data stack and perform the function of QUIT, which includes emptying the return stack, without displaying a message 77 | -------------------------------------------------------------------------------- /hardware/register_v2/turtle-float.fs: -------------------------------------------------------------------------------- 1 | \ turtle graphics library 2 | 3 | require pixels.fs 4 | 5 | :noname ." Welcome to Forthkit" ; is bootmessage 6 | false warnings ! 7 | 8 | fvariable x fvariable y fvariable theta \ initialized in start 9 | fvariable dx fvariable dy 10 | 11 | width 2/ constant hwidth 12 | height 2/ constant hheight 13 | 14 | : valid? ( x y -- b ) 15 | 0 height 1- within swap 16 | 0 width 1- within and ; 17 | 18 | pi 180e f/ fconstant rads 19 | 180e pi f/ fconstant degs ( needed? ) 20 | 21 | : deg2rad rads f* ; 22 | : rad2deg degs f* ; ( needed? ) 23 | 24 | : go ( x y -- ) s>f y f! s>f x f! ; 25 | 26 | : fhead ( t -- ) 27 | fdup theta f! deg2rad fdup 28 | fcos dx f! 29 | fsin dy f! ; 30 | : head ( t -- ) s>f fhead ; 31 | 32 | : pose ( x y t -- ) head go ; 33 | : home 0 0 90 pose ; 34 | 35 | : start ( -- ) clear home ; 36 | : turn ( a -- ) s>f theta f@ f+ fhead ; 37 | : plot ( x y -- ) 38 | fround f>s hwidth + 39 | fround f>s hheight + \ x y on *data* stack 40 | 2dup valid? if set else 2drop then ; 41 | : move ( d -- ) 42 | dy f@ dx f@ y f@ x f@ 0 do \ note: on *floating point* stack 43 | fover fover plot 44 | 2 fpick f+ fswap \ x+=dx 45 | 3 fpick f+ fswap \ y+=dy 46 | loop 47 | x f! y f! fdrop fdrop ; 48 | 49 | : f+! ( x addr -- ) dup f@ f+ f! ; ( note dup is address on *data* stack ) 50 | : jump ( d -- ) 51 | s>f fdup 52 | dx f@ f* x f+! 53 | dy f@ f* y f+! ; 54 | 55 | ( drawing things! ) 56 | 57 | : angle ( sides -- angle ) 360 swap / ; 58 | : draw ( len angle sides -- ) 0 do 2dup turn move loop 2drop ; 59 | : polygon ( len sides -- ) dup angle swap draw ; 60 | 61 | : triangle ( len -- ) 3 polygon ; 62 | : square ( len -- ) 4 polygon ; 63 | : pentagon ( len -- ) 5 polygon ; 64 | : hexagon ( len -- ) 6 polygon ; 65 | : circle ( len -- ) 36 polygon ; 66 | 67 | : shapes start 30 30 go 50 hexagon 50 pentagon 50 square 50 triangle show ; 68 | 69 | : star ( len -- ) 144 5 draw ; 70 | 71 | : burst start 60 0 do i 6 * head 0 0 go 80 move loop show ; 72 | 73 | : squaral start 35 -70 go 20 0 do 140 move 126 turn loop show ; 74 | 75 | : rose start 0 54 0 do 2 + dup move 84 turn loop show ; 76 | 77 | : spiral-rec 1 + dup move 92 turn dup 110 < if recurse then ; 78 | : spiral start 1 spiral-rec show ; 79 | 80 | \ shim for old version of gforth (e.g. apt install gforth gives 0.7.3) 81 | \ : [: ( -- ) postpone ahead :noname ; immediate compile-only 82 | \ : ;] ( -- xt ) postpone ; ] postpone then latestxt postpone literal ; immediate compile-only 83 | 84 | : spin dup angle swap 0 do 2dup turn execute loop 2drop ; 85 | : stars start [: 80 star ;] 3 spin show ; 86 | 87 | : spiro start [: 6 circle ;] 20 spin show ; 88 | 89 | : arc 0 do 2dup turn move loop 2drop ; 90 | : petal 2 0 do 4 6 16 arc 1 -6 16 arc 180 turn loop ; 91 | : flower start [: petal ;] 15 spin show ; 92 | 93 | : demo burst shapes squaral spiro stars rose flower spiral ; 94 | demo 95 | 96 | ( Kock curve experiment ) 97 | 98 | variable 'koch 99 | : curve dup 0 > if 2dup 1 - swap 3 / swap 'koch @ execute else drop move then ; 100 | : koch 2dup curve -60 turn 2dup curve 120 turn 2dup curve -60 turn 2dup curve 2drop ; 101 | ' koch 'koch ! 102 | 103 | start 104 | -80 0 go 105 | 50 1 curve 106 | show 107 | 108 | start 109 | -80 0 go 110 | 100 2 curve 111 | show 112 | 113 | start 114 | -80 0 go 115 | 200 3 curve 116 | show 117 | 118 | start 119 | -80 0 go 120 | 400 4 curve 121 | show 122 | 123 | : snowflake 3 0 do 2dup curve 120 turn loop 2drop ; 124 | 125 | start 126 | -80 0 go 127 | 80 0 snowflake 128 | show 129 | 130 | start 131 | -80 0 go 132 | 50 1 snowflake 133 | show 134 | 135 | start 136 | -80 0 go 137 | 50 2 snowflake 138 | show 139 | -------------------------------------------------------------------------------- /hardware/register/readme.md: -------------------------------------------------------------------------------- 1 | TODO: instruction set has changed 2 | 3 | # Register Virtual Machine (Minimal) 4 | 5 | This is a minimal version of the register-based virtual machine with just the core components needed to start fresh development. 6 | 7 | ## Files 8 | 9 | - `machine.c` - The C implementation of the 16-bit register-based virtual machine 10 | - `machine.fs` - The Forth implementation of the virtual machine (for development/testing) 11 | - `memory.fs` - VM memory system and block I/O (used by machine.fs) 12 | - `assembler.fs` - Assembly tools and compiler (depends on memory.fs) 13 | - `machine` - Pre-compiled executable (ready to use) 14 | - `build.sh` - Build script 15 | - `readme.md` - This documentation 16 | 17 | ## Building 18 | 19 | Build from source: 20 | ```bash 21 | ./build.sh 22 | ``` 23 | 24 | This compiles `machine.c` to `machine` executable. Any gcc errors will be displayed. 25 | 26 | ## Running 27 | 28 | ### Option 1: Run compiled C VM 29 | The machine loads and executes bytecode from `block0.bin`: 30 | ```bash 31 | ./machine 32 | ``` 33 | 34 | If no `block0.bin` exists, it will show an error or halt immediately. 35 | 36 | ### Option 2: Run Forth VM interactively 37 | For development and testing: 38 | ```bash 39 | gforth machine.fs 40 | ``` 41 | 42 | This loads the VM in Forth where you can: 43 | - Single-step through instructions with `step` 44 | - Examine registers and memory 45 | - Test VM operations interactively 46 | 47 | ## VM Architecture 48 | 49 | This is a 16-bit register-based virtual machine with: 50 | - **16 registers** (R0-R15, with R0 as program counter) 51 | - **64KB memory space** (addresses 0x0000 to 0xFFFF) 52 | - **16 instruction opcodes** (complete but minimal instruction set) 53 | - **Little-endian** byte order 54 | - **Block-based storage** system (block0.bin, block1.bin, etc.) 55 | 56 | ### Instruction Set 57 | 0. `HALT` - Halt execution 58 | 1. `LDC` - Load constant 59 | 2. `LD+` - Load with increment 60 | 3. `ST+` - Store with increment 61 | 4. `CP?` - Conditional copy 62 | 5. `ADD` - Addition 63 | 6. `SUB` - Subtraction 64 | 7. `MUL` - Multiplication 65 | 8. `DIV` - Division 66 | 9. `NAND` - Bitwise NAND 67 | 10. `SHL` - Shift left 68 | 11. `SHR` - Shift right 69 | 12. `IN` - Input character 70 | 13. `OUT` - Output character 71 | 14. `READ` - Read block 72 | 15. `WRITE` - Write block 73 | 74 | ## Starting Fresh 75 | 76 | This minimal system provides just the virtual machine foundation. From here you can build: 77 | 78 | - **Assemblers** for generating bytecode 79 | - **Compilers** for high-level languages 80 | - **Operating systems** and kernels 81 | - **Applications** and games 82 | - **Development tools** and debuggers 83 | 84 | ## Examples and Complete System 85 | 86 | See the complete system in `../register_v2/` for: 87 | - Full Forth kernel and compiler 88 | - Assembler tools 89 | - Graphics libraries (pixels, turtle graphics) 90 | - Example programs and tests 91 | - Bootstrap process documentation 92 | 93 | The book.md in the repository root contains the complete tutorial for building from this minimal VM up to a full Forth system with graphics capabilities. 94 | 95 | # Bugs 96 | 97 | - Seem to need to press Enter before interacting 98 | - Forth-based machine doesn't echo as keys entered and doesn't allow editing 99 | - Mitigated by `cat - | gforth ...` 100 | - d. and u. don't work with negative numbers 101 | - Some words (e.g. `+foo` not flagged as unable to find) 102 | 103 | # Fragments 104 | 105 | ```forth 106 | \ poor man's . ( n -- ) print decimal number 107 | : . dup 10000 / dup 48 + emit 10000 * - 108 | dup 1000 / dup 48 + emit 1000 * - 109 | dup 100 / dup 48 + emit 100 * - 110 | dup 10 / dup 48 + emit 10 * - 111 | 48 + emit ; 112 | ``` -------------------------------------------------------------------------------- /hardware/register_v2/assembler.fs: -------------------------------------------------------------------------------- 1 | [undefined] buffer: [if] 2 | : buffer: create allot ; \ TODO: not defined in gforth?! 3 | [then] 4 | 5 | $10000 constant memory-size 6 | memory-size buffer: memory ( create memory memory-size allot ) memory memory-size erase 7 | variable h memory h ! 8 | 9 | false warnings ! \ intentionally redefining (here c, ,) 10 | 11 | : here h @ memory - ; 12 | : c, ( c -- ) h @ c! 1 h +! ; 13 | : , ( cc -- ) dup c, 8 rshift c, ; \ 16-bit little endian 14 | : s! ( val addr -- ) memory + over 8 rshift over 1+ c! c! ; \ store 16-bit value at address (relative to memory) 15 | : s@ ( addr -- val ) memory + dup c@ swap 1+ c@ 8 lshift or ; \ fetch 16-bit value from address (relative to memory) TODO: unused? 16 | 17 | true warnings ! 18 | 19 | : 2nybbles, ( x i -- ) 4 lshift or c, ; 20 | : 4nybbles, ( z y x i -- ) 2nybbles, 2nybbles, ; 21 | 22 | : halt, ( x -- ) 0 2nybbles, ; \ halt(x) (halt with exit code x) 23 | : ldc, ( v x -- ) 1 2nybbles, c, ; \ x=v (load constant signed v into x) 24 | : ld+, ( z y x -- ) 2 4nybbles, ; \ z<-[y] y+=x (load from memory and inc/dec pointer) 25 | : st+, ( z y x -- ) 3 4nybbles, ; \ z->[y] y+=x (store to memory and inc/dec pointer) 26 | : cp?, ( z y x -- ) 4 4nybbles, ; \ z=y if x=0 (conditional copy) 27 | : add, ( z y x -- ) 5 4nybbles, ; \ z=y+x (addition) 28 | : sub, ( z y x -- ) 6 4nybbles, ; \ z=y-x (subtraction) 29 | : mul, ( z y x -- ) 7 4nybbles, ; \ z=y*x (multiplication) 30 | : div, ( z y x -- ) 8 4nybbles, ; \ z=y/x (division) 31 | : nand, ( z y x -- ) 9 4nybbles, ; \ z=y nand x (not-and) 32 | : shl, ( z y x -- ) 10 4nybbles, ; \ z=y<>x (bitwise shift-right) 34 | : in, ( y x -- ) 12 2nybbles, ; \ x=getc() (read from console) 35 | : out, ( y x -- ) 13 2nybbles, ; \ putc(x) (write to console) 36 | : read, ( z y x -- ) 14 4nybbles, ; \ read(z,y,x) (file z of size y -> address x) 37 | : write, ( z y x -- ) 15 4nybbles, ; \ write(z,y,x) (file z of size y <- address x) 38 | 39 | ( --- secondary instructions ------------------------------------------------- ) 40 | 41 | 0 constant pc 42 | 1 constant zero 43 | 44 | : cp, ( y x -- ) zero cp?, ; \ y=x (unconditional copy) 45 | : ld, ( y x -- ) zero ld+, ; \ y<-[x] (load from memory) 46 | : st, ( y x -- ) zero st+, ; \ y->[x] (store to memory) 47 | 48 | : jump, ( addr -- ) pc pc ld, , ; \ unconditional jump to address (following cell) 49 | 50 | : not, ( y x -- ) dup nand, ; \ y=~x (bitwise/logical not) 51 | : and, 2 pick -rot nand, dup not, ; 52 | : or, ( z y x -- ) dup dup not, over dup not, nand, ; \ z=y|x (bitwise/logical or) 53 | 54 | ( --- assembler tools -------------------------------------------------------- ) 55 | 56 | : label ( -- addr ) here constant ; \ current address within memory 57 | : branch, ( -- dest ) 0 jump, here 2 - ; \ dummy jump, push pointer to patch 58 | : patch, ( orig -- ) here swap s! ; \ patch jump to continue here 59 | 60 | ( --- read/write blocks ------------------------------------------------------ ) 61 | 62 | : block-file ( n -- c-addr u ) \ returns a string in pad of the form "block.bin" 63 | s" block" 64 | rot 0 <# #s #> s+ \ s+ is a gforth extension 65 | s" .bin" s+ 66 | ; 67 | 68 | : read-block ( block memaddr len ) 69 | rot block-file 2dup file-status 0<> if ." Block file not found " else drop then 70 | r/o open-file throw 71 | rot memory + -rot dup >r 72 | read-file throw drop r> 73 | close-file throw ; 74 | 75 | : write-block ( block memaddr len ) 76 | rot block-file w/o create-file throw 77 | rot memory + -rot dup >r 78 | write-file throw r> 79 | close-file throw ; 80 | 81 | : read-boot-block ( -- ) 0 0 memory-size read-block ; 82 | : write-boot-block ( -- ) 0 0 here write-block ; 83 | -------------------------------------------------------------------------------- /hardware/register_v2/machine.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | unsigned short reg[0x10]; 4 | unsigned char mem[0x10000]; 5 | 6 | FILE* openBlock(unsigned short block, const char * mode) 7 | { 8 | char filename[0xf]; 9 | snprintf(filename, sizeof(filename), "block%d.bin", block); 10 | return fopen(filename, mode); 11 | } 12 | 13 | void readBlock(unsigned short block, unsigned short address, long maxsize) 14 | { 15 | FILE *file = openBlock(block, "r"); 16 | fseek(file, 0, SEEK_END); 17 | long size = ftell(file); 18 | fseek(file, 0, SEEK_SET); 19 | if (!file || !fread(mem + address, maxsize < size ? maxsize : size, 1, file)) // assumes size+address <= sizeof(mem) 20 | { 21 | printf("Could not open block file.\n"); 22 | } 23 | fclose(file); 24 | } 25 | 26 | void writeBlock(unsigned short block, unsigned short address, long size) 27 | { 28 | FILE *file = openBlock(block, "w"); 29 | if (!file || !fwrite(mem + address, 1, size, file)) 30 | { 31 | printf("Could not write block file.\n"); 32 | } 33 | fclose(file); 34 | } 35 | 36 | #define NEXT mem[reg[0]++] 37 | #define LOW(b) b & 0x0F 38 | #define HIGH(b) LOW(b >> 4); 39 | 40 | int main(void) 41 | { 42 | readBlock(0, 0, sizeof(mem)); 43 | while (1) 44 | { 45 | unsigned char c = NEXT; 46 | unsigned char i = HIGH(c); 47 | unsigned char x = LOW(c); 48 | 49 | // instructions that need a second byte (all except HALT, LDC, IN, OUT) 50 | if (i >= 2 && i <= 15 && i != 12 && i != 13) { 51 | unsigned char j = NEXT; 52 | unsigned char y = HIGH(j); 53 | unsigned char z = LOW(j); 54 | 55 | switch(i) 56 | { 57 | case 2: 58 | reg[z] = mem[reg[y]] | (mem[reg[y] + 1] << 8); reg[y] += reg[x]; 59 | if (z == 0 && y == 0 && x == 1) // jump? 60 | { 61 | //printf("JUMP: %i\n", reg[z]); 62 | } 63 | break; // LD+ 64 | case 3: 65 | mem[reg[y]] = reg[z] & 0xFF; 66 | mem[reg[y] + 1] = reg[z] >> 8; 67 | reg[y] += reg[x]; 68 | break; // ST+ 69 | case 4: if (reg[x] == 0) reg[z] = reg[y]; break; // CP? 70 | case 5: reg[z] = (unsigned short)((int)(short)reg[y] + (int)(short)reg[x]); break; // ADD 71 | case 6: reg[z] = (unsigned short)((int)(short)reg[y] - (int)(short)reg[x]); break; // SUB 72 | case 7: reg[z] = (unsigned short)((int)(short)reg[y] * (int)(short)reg[x]); break; // MUL 73 | case 8: reg[z] = (unsigned short)((int)(short)reg[y] / (int)(short)reg[x]); break; // DIV 74 | case 9: reg[z] = ~(reg[y] & reg[x]); break; // NAND 75 | case 10: reg[z] = reg[y] << reg[x]; break; // SHL 76 | case 11: reg[z] = (unsigned short)reg[y] >> reg[x]; break; // SHR (logical) 77 | case 14: readBlock(reg[z], reg[y], reg[x]); break; // READ 78 | case 15: writeBlock(reg[z], reg[y], reg[x]); break; // WRITE 79 | default: printf("Invalid instruction! (%i)\n", i); return 1; 80 | } 81 | } 82 | else { 83 | // instructions that only use one byte 84 | switch(i) 85 | { 86 | case 0: return reg[x]; // HALT 87 | case 1: { 88 | signed char v = NEXT; // fetch signed byte and sign-extend 89 | reg[x] = v; 90 | break; // LDC 91 | } 92 | case 12: reg[x] = getc(stdin); break; // IN 93 | case 13: putc(reg[x], stdout); break; // OUT 94 | default: printf("Invalid instruction! (%i)\n", i); return 1; 95 | } 96 | } 97 | } 98 | } -------------------------------------------------------------------------------- /hardware/register_v2/turtle-fixed.fs: -------------------------------------------------------------------------------- 1 | here 2 | 255 c, 255 c, 255 c, 255 c, 254 c, 254 c, 254 c, 253 c, 253 c, 252 c, 3 | 251 c, 250 c, 249 c, 248 c, 247 c, 246 c, 245 c, 244 c, 242 c, 241 c, 4 | 240 c, 238 c, 236 c, 235 c, 233 c, 231 c, 229 c, 227 c, 225 c, 223 c, 5 | 221 c, 218 c, 216 c, 214 c, 211 c, 209 c, 206 c, 203 c, 201 c, 198 c, 6 | 195 c, 192 c, 189 c, 186 c, 183 c, 180 c, 177 c, 174 c, 170 c, 167 c, 7 | 164 c, 160 c, 157 c, 153 c, 149 c, 146 c, 142 c, 138 c, 135 c, 131 c, 8 | 127 c, 123 c, 119 c, 115 c, 111 c, 107 c, 103 c, 99 c, 95 c, 91 c, 9 | 87 c, 82 c, 78 c, 74 c, 70 c, 65 c, 61 c, 57 c, 52 c, 48 c, 10 | 43 c, 39 c, 35 c, 30 c, 26 c, 21 c, 17 c, 12 c, 8 c, 3 c, 0 c, ( TODO <-- should be -1 ) 11 | constant table 12 | table . 13 | : cos 14 | abs 360 mod dup 180 >= if 360 swap - then 15 | dup 90 >= if -1 180 rot - else 1 swap then 16 | table + c@ 1+ * ; 17 | 18 | : sin 90 - cos ; 19 | 20 | variable x variable y variable theta 21 | variable dx variable dy 22 | 23 | \ : point-x x @ 8 rshift width 2/ + ; / TODO: rshift doesn't handle sign extension 24 | \ : point-y y @ 8 rshift height 2/ swap - ; / TODO: rshift doesn't handle sign extension 25 | : point-x x @ 128 + 256 / width 2/ + ; 26 | : point-y y @ 128 + 256 / height 2/ swap - ; 27 | : valid-x? point-x 0 width 1- within ; 28 | : valid-y? point-y 0 height 1- within ; 29 | : valid? valid-x? valid-y? and ; 30 | : plot valid? if point-x point-y set then ; 31 | 32 | : go 8 lshift y ! 8 lshift x ! ; 33 | \ : go 256 * y ! 256 * x ! ; 34 | : head dup theta ! dup cos dx ! sin dy ! ; 35 | : pose head go ; 36 | : home 0 0 90 pose ; 37 | 38 | : start clear home ; 39 | : turn theta @ + head ; 40 | : move 0 do dx @ x +! dy @ y +! plot loop ; 41 | : jump dup dx @ * x +! dy @ * y +! ; 42 | 43 | ( drawing things! ) 44 | 45 | : angle ( sides -- angle ) 360 swap / ; 46 | : draw ( len angle sides -- ) 0 do 2dup turn move loop 2drop ; 47 | : polygon ( len sides -- ) dup angle swap draw ; 48 | 49 | : triangle ( len -- ) 3 polygon ; 50 | : square ( len -- ) 4 polygon ; 51 | : pentagon ( len -- ) 5 polygon ; 52 | : hexagon ( len -- ) 6 polygon ; 53 | : circle ( len -- ) 36 polygon ; 54 | 55 | : shapes start 30 30 go 50 hexagon 50 pentagon 50 square 50 triangle show ; 56 | 57 | : star ( len -- ) 144 5 draw ; 58 | 59 | : burst start 60 60 go 60 0 do i 6 * head 0 0 go 80 move loop show ; 60 | 61 | : squaral start 35 -70 go 20 0 do 140 move 126 turn loop show ; 62 | 63 | : rose start 0 54 0 do 2 + dup move 84 turn loop drop show ; 64 | 65 | : spiral-rec 1 + dup move 92 turn dup 110 < if tail-recurse then drop ; 66 | : spiral start 1 spiral-rec show ; 67 | 68 | \ shim for old version of gforth (e.g. apt install gforth gives 0.7.3) 69 | \ : [: ( -- ) postpone ahead :noname ; immediate compile-only 70 | \ : ;] ( -- xt ) postpone ; ] postpone then latestxt postpone literal ; immediate compile-only 71 | 72 | : spin dup angle swap 0 do 2dup turn execute loop 2drop ; 73 | \ : stars start [: 80 star ;] 3 spin show ; 74 | 75 | \ : spiro start [: 6 circle ;] 20 spin show ; 76 | 77 | : arc 0 do 2dup turn move loop 2drop ; 78 | : petal 2 0 do 4 6 16 arc 1 -6 16 arc 180 turn loop ; 79 | \ : flower start [: petal ;] 15 spin show ; 80 | 81 | \ : demo burst shapes squaral spiro stars rose flower spiral ; 82 | : demo burst shapes squaral rose spiral ; 83 | \ demo 84 | 85 | ( Kock curve experiment ) 86 | 87 | variable 'koch 88 | : curve dup 0 > if 2dup 1 - swap 3 / swap 'koch @ execute else drop move then ; 89 | : koch 2dup curve -60 turn 2dup curve 120 turn 2dup curve -60 turn 2dup curve 2drop ; 90 | ' koch 'koch ! 91 | 92 | \ start 93 | \ -80 0 go 94 | \ 50 1 curve 95 | \ show 96 | 97 | \ start 98 | \ -80 0 go 99 | \ 100 2 curve 100 | \ show 101 | 102 | \ start 103 | \ -80 0 go 104 | \ 200 3 curve 105 | \ show 106 | 107 | \ start 108 | \ -80 0 go 109 | \ 400 4 curve 110 | \ show 111 | 112 | : snowflake 3 0 do 2dup curve 120 turn loop 2drop ; 113 | 114 | \ start 115 | \ -80 0 go 116 | \ 80 0 snowflake 117 | \ show 118 | 119 | \ start 120 | \ -80 0 go 121 | \ 50 1 snowflake 122 | \ show 123 | 124 | \ start 125 | \ -80 0 go 126 | \ 50 2 snowflake 127 | \ show 128 | -------------------------------------------------------------------------------- /notes/transforth.md: -------------------------------------------------------------------------------- 1 | # [TransForth](https://github.com/AshleyF/TransForth) 2 | 3 | : HERE H @ ; 4 | : LATEST L @ ; 5 | : SP@ S @ ; 6 | : NEGATE -1 * ; 7 | : - ( a b -- diff) NEGATE + ; 8 | : 1+ 1 + ; 9 | : 1- 1 - ; 10 | : DEPTH ( -- n) S0 SP@ - ; 11 | : CLEAR ( --) S0 1+ S ! ; 12 | : DROP ( a -- ) SP@ 1+ S ! ; 13 | : , ( v --) HERE ! HERE 1+ H ! ; 14 | : BEGIN HERE ; IMMEDIATE 15 | : UNTIL ' 0BRANCH , , ; IMMEDIATE 16 | : PICK SP@ + 1+ @ ; 17 | : OVER ( a b -- a b a) 1 PICK ; 18 | : 2DUP ( a b -- a b a b) OVER OVER ; 19 | : 2+ 2 + ; 20 | : 2- 2 - ; 21 | : 2* 2 * ; 22 | : 2/ 2 / ; 23 | : DUP ( a -- a a) 0 PICK ; 24 | : >R R @ DUP DUP 1- R ! @ R @ ! ! ; 25 | : R> R @ 1+ @ R @ @ R @ 1+ ! R @ 1+ R ! ; 26 | : R@ R @ 1+ @ ; 27 | : ROLL SP@ 1+ + DUP @ >R BEGIN DUP >R 1- DUP @ R> ! DUP SP@ 2+ = UNTIL DROP R> SP@ 1+ ! ; 28 | : ? @ . ; 29 | : ROT ( a b c -- b c a) 2 ROLL ; 30 | : SWAP ( a b -- b a) 1 ROLL ; 31 | : +! ( add a -- ) DUP @ ROT + SWAP ! ; 32 | : ++! ( a -- a++) DUP @ 1+ SWAP ! ; 33 | : COUNTER 2* 3 + R @ + @ ; 34 | : I 0 COUNTER ; 35 | : J 1 COUNTER ; 36 | : K 2 COUNTER ; 37 | : -ROT ( a b c -- c a b) ROT ROT ; 38 | : NIP ( a b -- b) SWAP DROP ; 39 | : TUCK ( a b -- b a b) SWAP OVER ; 40 | : 2DROP ( a b -- ) DROP DROP ; 41 | : 3DROP ( a b c -- ) 2DROP DROP ; 42 | : 2OVER ( a b c d -- a b c d a b) 3 PICK 3 PICK ; 43 | : 3DUP ( a b c -- a b c a b c) DUP 2OVER ROT ; 44 | : SQUARE ( a -- a^2) DUP * ; 45 | : CUBE ( a -- a^3) DUP DUP * * ; 46 | : /MOD ( a b -- rem quot) 2DUP MOD -ROT / ; 47 | : TRUE ( -- t) -1 ; \ normally constant 48 | : FALSE ( -- f) 0 ; \ normally constant 49 | : NOT ( a -- ~a) DUP NAND ; 50 | : AND ( a b -- a&b) NAND NOT ; 51 | : OR ( a b -- a|b) NOT SWAP NOT NAND ; 52 | : NOR ( a b -- ~a|b) OR NOT ; 53 | : XOR ( a b -- a^b) 2DUP AND -ROT NOR NOR ; 54 | : XNOR ( a b -- ~a^b) XOR NOT ; 55 | : < ( a b -- a -ROT = OR NOT ; 56 | : <= ( a b -- a<=b) 2DUP < -ROT = OR ; 57 | : >= ( a b -- a>=b) 2DUP > -ROT = OR ; 58 | : <> ( a b -- ?) = NOT ; 59 | : 0> 0 > ; 60 | : 0= 0 = ; 61 | : 0< 0 < ; 62 | : 0<> 0 <> ; 63 | : IF ' 0BRANCH , HERE 0 , ; IMMEDIATE 64 | : ELSE ' BRANCH , HERE 0 , SWAP HERE SWAP ! ; IMMEDIATE 65 | : THEN HERE SWAP ! ; IMMEDIATE 66 | : ABS ( n -- |n|) DUP 0< IF NEGATE THEN ; 67 | : MIN 2DUP > IF SWAP THEN DROP ; 68 | : MAX 2DUP < IF SWAP THEN DROP ; 69 | : WHILE ' 0BRANCH , HERE 0 , ; IMMEDIATE 70 | : REPEAT ' BRANCH , HERE 1+ SWAP ! , ; IMMEDIATE 71 | : LEAVE ' BRANCH , HERE SWAP 0 , ; IMMEDIATE 72 | : DO HERE ' >R , ' >R , ; IMMEDIATE 73 | : LOOP ' R> , ' R> , ' 1+ , ' 2DUP , ' = , ' 0BRANCH , , ' 2DROP , ; IMMEDIATE 74 | : +LOOP ' R> , ' R> , ' ROT , ' + , ' 2DUP , ' = , ' 0BRANCH , , ' 2DROP , ; IMMEDIATE 75 | : .S SP@ 1- S0 2DUP < IF DO I @ . -1 +LOOP ELSE 2DROP THEN ; 76 | : CRLF 13 ECHO 10 ECHO ; 77 | : SP 32 ; 78 | : DUMP ( m n -- ) DO I . I @ . CRLF LOOP ; 79 | : ?DELIM ( v d -- v ?) 2DUP SP = IF >= ELSE = THEN ; 80 | : ?WS SP ?DELIM ; 81 | : SKIPWS KEY ?WS IF DROP SKIPWS THEN ; \ leaves first non-whitespace char on stack 82 | : TOKEN ( delim -- tok) >R HERE 1+ R@ SP = 83 | IF SKIPWS ELSE KEY THEN BEGIN 84 | OVER ! 1+ KEY R@ ?DELIM 85 | UNTIL R> 2DROP HERE - 1- HERE ! ; 86 | : WORD SP TOKEN ; 87 | : CFA ( addr -- c) 5 + ; 88 | : LINKA ( addr -- l) 4 + ; 89 | : HEADER WORD LATEST HERE LINKA ! HERE L ! HERE CFA H ! ; 90 | : FORGET WORD FIND DUP H ! LINKA @ L ! ; 91 | : TOKENCHARS ( -- b a) HERE HERE @ + 1+ HERE 1+ ; 92 | : 0-ASCII 48 ; 93 | : 9-ASCII 57 ; 94 | : ?DIGIT ( c -- c ?) DUP 0-ASCII >= OVER 9-ASCII <= AND ; 95 | : ?NUMBER 0 TRUE TOKENCHARS DO I @ ?DIGIT SWAP >R AND SWAP 10 * R> + 0-ASCII - SWAP LOOP DUP NOT IF SWAP DROP THEN ; 96 | : ?FOUND ( w -- ?) DUP 0 >= ; 97 | : HIGHBIT -2147483648 ; 98 | : ISIMMEDIATE ( addr -- ?) @ HIGHBIT AND HIGHBIT = ; 99 | : OUTER WORD FIND ?FOUND IF 100 | DUP ISIMMEDIATE ISINTERACTIVE OR 101 | IF EXEC ELSE CFA , THEN 102 | ELSE 103 | DROP ?NUMBER IF 104 | ISINTERACTIVE NOT IF LITADDR , , THEN 105 | ELSE 106 | 63 ECHO SP ECHO \ ? 107 | THEN 108 | THEN 109 | OUTER ; -------------------------------------------------------------------------------- /hardware/stack/machine.c: -------------------------------------------------------------------------------- 1 | #include "../shared/memory.c" 2 | 3 | unsigned short dat[0x10]; 4 | unsigned short ret[0x10]; 5 | unsigned short p = 0, d = 0xf, r = 0xf; 6 | 7 | #define STACK(s, delta) s = (s + delta) & 0xf 8 | #define X dat[d] 9 | #define Y dat[(d - 1) & 0xf] 10 | #define Z dat[(d - 2) & 0xf] 11 | #define R ret[r] 12 | #define BINOP(op) Y = Y op X; X = 0; /* TODO: remove X = 0 */ STACK(d, -1) 13 | 14 | unsigned short next() { 15 | unsigned short h = mem[p++]; 16 | unsigned short l = mem[p++]; 17 | return l << 8 | h; 18 | } 19 | 20 | int main(void) { 21 | readBlock(0, 0, sizeof(mem)); 22 | //int count = 0; while (count++ < 1000) { 23 | while (1) { 24 | unsigned short c = next(); 25 | if ((c & 1) == 0) { // call? 26 | STACK(r, 1); 27 | R = p; 28 | p = c; 29 | //printf("%x CALL: %x\n", R - 2, p); 30 | // TODO: TCO 31 | } else { // instructions 32 | for (short slot = 0; slot < 0xf; slot += 5) { 33 | short i = (c >> (11 - slot)) & 0x1F; 34 | //printf("%x[%x] INSTRUCTION: %i\n", p - 2, slot / 5, i); 35 | switch (i) { 36 | case 0: 37 | printf("STACK (%i): %i %i %i %i %i %i %i %i %i %i %i %i %i %i %i %i RETURN: %i %i %i\n", d, dat[(d - 15) & 0xf], dat[(d - 14) & 0xf], dat[(d - 13) & 0xf], dat[(d - 12) & 0xf], dat[(d - 11) & 0xf], dat[(d - 10) & 0xf], dat[(d - 9) & 0xf], dat[(d - 8) & 0xf], dat[(d - 7) & 0xf], dat[(d - 6) & 0xf], dat[(d - 5) & 0xf], dat[(d - 4) & 0xf], dat[(d - 3) & 0xf], X, Z, Y, R, ret[(r - 1) & 0xf], ret[(r - 2) & 0xf]); 38 | //writeBlock(1, 0, sizeof(mem)); 39 | //break; 40 | return X; // HALT - Halt execution 41 | case 1: BINOP(+); break; // ADD - Addition 42 | case 2: BINOP(-); break; // SUB - Subtraction 43 | case 3: BINOP(*); break; // MUL - Multiplication 44 | case 4: BINOP(/); break; // DIV - Division 45 | case 5: X = ~X; break; // NOT - Bitwise not 46 | case 6: BINOP(&); break; // AND - Bitwise and 47 | case 7: BINOP(|); break; // OR - Bitwise or 48 | case 8: BINOP(^); break; // XOR - Bitwise xor 49 | case 9: BINOP(<<); break; // SHL - Shift left 50 | case 10: BINOP(>>); break; // SHR - Shift right 51 | case 11: STACK(d, 1); X = getc(stdin); break; // IN - Input character 52 | case 12: putc(X, stdout); STACK(d, -1); break; // OUT - Output character 53 | case 13: readBlock(Z, Y, X); STACK(d, -3); break; // READ - Read block 54 | case 14: writeBlock(Z, Y, X); STACK(d, -3); break; // WRITE - Write block 55 | case 15: STACK(d, 1); X = mem[Y] | (mem[Y + 1] << 8); Y += 2; break; // LD16+ - Fetch cell at address, and increment over 56 | case 16: STACK(d, 1); X = mem[Y]; Y++; break; // LD8+ - Fetch byte at address, and increment over 57 | case 17: mem[Y] = X & 0xFF; mem[Y + 1] = X >> 8; Y += 2; STACK(d, -1); break; // ST16+ - Store cell at address, and increment over 58 | case 18: mem[Y] = X & 0xFF; Y++; STACK(d, -1); break; // ST8+ - Store byte at address, and increment over 59 | case 19: STACK(d, 1); X = next(); break; // LIT16 - Fetch literal next cell 60 | case 20: STACK(d, 1); X = (signed char)mem[p++]; break; // LIT8 - Fetch literal next signed byte 61 | case 21: if (X == 0) { p += (signed char)mem[p]; slot = 0xf; } else { p++; } STACK(d, -1); break; // 0JUMP - Jump to relative to offset in next byte if T = 0 62 | case 22: if (R > 0) { R--; p -= mem[p]; slot = 0xf; } else { STACK(R, -1); p++; } break; // NEXT - If R > 0, R-- and loop back to next byte negative offset, otherwise drop R and continue 63 | case 23: STACK(d, -1); break; // DROP - Drop top of stack 64 | case 24: STACK(d, 1); X = Y; break; // DUP - Duplicate top of stack 65 | case 25: STACK(d, 1); X = Z; break; // OVER - yx -> yxy 66 | case 26: short t = X; X = Y; Y = t; break; // SWAP - yx -> xy 67 | case 27: STACK(r, 1); R = X; STACK(d, -1); break; // PUSH - Push top of data stack to return stack 68 | case 28: STACK(d, 1); X = R; STACK(r, -1); break; // POP - Pop top of return stack to data stack 69 | case 29: STACK(d, 1); X = R; break; // PEEK - Copy top of return stack to data stack 70 | case 30: p = R; STACK(r, -1); slot = 0xf; break; // RET - Return from call 71 | case 31: break; // NOP 72 | } 73 | } 74 | } 75 | } 76 | } -------------------------------------------------------------------------------- /hardware/stack/assembler.fs: -------------------------------------------------------------------------------- 1 | require ../shared/memory.fs 2 | 3 | false warnings ! \ redefining gforth words 4 | 5 | : here h @ memory - ; 6 | : c, ( c -- ) h @ c! 1 h +! ; 7 | : , ( cc -- ) dup c, 8 rshift c, ; 8 | : s! ( val addr -- ) memory + over 8 rshift over 1+ c! c! ; 9 | : s@ ( addr -- val ) memory + dup c@ swap 1+ c@ 8 lshift or ; 10 | 11 | true warnings ! 12 | 13 | variable shiftbits 14 | : initslot 11 shiftbits ! ; 15 | initslot 16 | 17 | variable h' 18 | : slot, ( i -- ) 19 | shiftbits @ 11 = if \ first slot? 20 | $ffff h @ dup h' ! ! 2 h +! \ h'=h, initialize no-ops, h+=2 21 | then 22 | shiftbits @ lshift \ shift instruction to slot 23 | 0x1f shiftbits @ lshift invert h' @ @ and \ fetch and mask off slot 24 | or h' @ ! \ place instruction 25 | -5 shiftbits +! 26 | shiftbits @ 0<= if 11 shiftbits ! then ; 27 | 28 | : verify-sbyte dup -128 127 within invert if ." Signed byte out of range: " . throw then ; \ TODO: does within handle negatives? 29 | : verify-ubyte dup 0 255 within invert if ." Unsigned byte out of range: " . throw then ; \ TODO: does within handle negatives? 30 | 31 | : halt, 0 slot, ; \ halt execution 32 | : add, 1 slot, ; \ addition 33 | : sub, 2 slot, ; \ subtraction 34 | : mul, 3 slot, ; \ multiplication 35 | : div, 4 slot, ; \ division 36 | : not, 5 slot, ; \ bitwise not 37 | : and, 6 slot, ; \ bitwise and 38 | : or, 7 slot, ; \ bitwise or 39 | : xor, 8 slot, ; \ bitwise xor 40 | : shl, 9 slot, ; \ shift left 41 | : shr, 10 slot, ; \ shift right 42 | : in, 11 slot, ; \ input character 43 | : out, 12 slot, ; \ output character 44 | : read, 13 slot, ; \ read block 45 | : write, 14 slot, ; \ write block 46 | : ld16+, 15 slot, ; \ fetch cell at address, and increment over 47 | : ld8+, 16 slot, ; \ fetch byte at address, and increment over 48 | : st16+, 17 slot, ; \ store cell at address, and increment over 49 | : st8+, 18 slot, ; \ store byte at address, and increment over 50 | : lit16, 19 slot, , ; \ fetch literal next cell 51 | : lit8, 20 slot, verify-sbyte c, ; \ fetch literal next signed byte 52 | : 0jump, 21 slot, here - verify-sbyte c, ; \ jump to relative address in next cell if T >= 0 53 | : next, 22 slot, here swap - verify-ubyte c, ; \ if R <= 0, drop R and continue, otherwise R-- and loop back to relative address in next cell 54 | : drop, 23 slot, ; \ drop top of stack 55 | : dup, 24 slot, ; \ duplicate top of stack 56 | : over, 25 slot, ; \ yx -> yxy 57 | : swap, 26 slot, ; \ yx -> xy 58 | : push, 27 slot, ; \ push top of data stack to return stack 59 | : pop, 28 slot, ; \ pop top of return stack to data stack 60 | : peek, 29 slot, ; \ copy top of return stack to data stack 61 | : ret, 30 slot, ; \ return from call 62 | : nop, 31 slot, ; \ no-op 63 | 64 | : align, initslot here 1 and 0<> if 1 h +! then ; \ align here on even address boundary 65 | : for, push, initslot here ; \ start for/next loop 66 | 67 | : call, ( addr -- ) initslot dup 1 and 0= if , else ." Expected even-aligned address" throw then ; 68 | : jump, ( addr -- ) call, ret, ; 69 | 70 | : literal, dup -128 127 within if lit8, else lit16, then ; \ TODO: does within handle negatives? 71 | : zero, dup, dup, xor, ; \ trick to push a zero 72 | 73 | : >r, push, ; \ ( x -- ) ( R: x -- ) move x to return stack [synonym] 74 | : r>, pop, ; \ ( -- x ) ( R: x -- ) move x from return stack [synonym] 75 | : r@, peek, ; \ ( -- x ) ( R: x -- x ) copy x from return stack [synonym] 76 | : emit, out, ; \ emit ( char -- ) write to console [synonym] 77 | : key, in, ; \ key ( -- char ) read from console [synonym] 78 | 79 | : 2>r, swap, push, push, ; \ ( y x -- ) ( R: -- y x ) move y x pair to return stack 80 | : 2r>, pop, pop, swap, ; \ ( -- y x ) ( R: y x -- ) move y x pair from return stack 81 | : nip, swap, drop, ; \ ( y x -- x ) drop second stack value 82 | : tuck, swap, over, ; \ ( y x -- x y x ) copy top stack value under second value 83 | : 2dup, over, over, ; \ ( y x -- y x y x ) duplicate top two stack values 84 | : 2drop, drop, drop, ; \ ( y x -- ) remove top two stack values 85 | 86 | : label ( -- addr ) here constant ; 87 | : skip, ( -- dest ) 0 call, here 2 - ; \ call, but expected to halt and never return 88 | : start, ( orig -- ) align, here swap s! ; 89 | 90 | : write-boot-block ( -- ) 0 0 here write-block ; \ note: depends on redefined `here` -------------------------------------------------------------------------------- /notes/instructions.md: -------------------------------------------------------------------------------- 1 | # Interesting Instruction Sets 2 | 3 | ## [DCPU-16](https://web.archive.org/web/20120509184912/http://0x10c.com/doc/dcpu-16.txt) 4 | 5 | 16-bit, 32K words RAM, 8 registers + PC, SP, overflow (O) 6 | 7 | - Interesting: 8 | - Can manually assign to PC, push PC to stack, etc. 9 | - Can reference registers or memory at registers as values 10 | - Values: R, [R], [PC+R], pop [SP++], peek [SP], push [--SP], SP, PC, O [PC], literals 11 | - Copy (SET a to b) 12 | - ALU: ADD, SUB, MUL, DIV, MOD, SHL, SHR, AND, BOR, XOR 13 | - Conditional: IFE (a=b), IFN (a!=b), IFG (a>b), IFB (a&b!=0) 14 | - Jump: JSR 15 | 16 | ## [UM-32](https://esolangs.org/wiki/UM-32) 17 | 18 | 32-bit, 8 registers 19 | 20 | - Conditional: if C,A=B 21 | - Load/Store: A=B[C] / A[B]=C 22 | - ALU: A=B+C / A=B*C / A=B/C / A=B nand C 23 | - HALT 24 | - alloc/dealloc 25 | - I/O: C=getc() / putc(C) 26 | - JUMP (dup memory and set instruction pointer) 27 | - LIT: A = load immediate (25-bit quantity) 28 | 29 | ## Nga (RetroForth) 30 | 31 | 0 nop 5 push 10 ret 15 fetch 20 div 25 zret 32 | 1 lit 6 pop 11 eq 16 store 21 and 26 halt 33 | 2 dup 7 jump 12 neq 17 add 22 or 27 ienum 34 | 3 drop 8 call 13 lt 18 sub 23 xor 28 iquery 35 | 4 swap 9 ccall 14 gt 19 mul 24 shift 29 iinvoke 36 | 37 | ## RM16 38 | 39 | 16-bit, 16 registers (including PC as register 0) 40 | 41 | - Interesting: 42 | - Can get/set PC, so no JMP/CALL/EXEC needed 43 | - Single SHIFT instruction with positive (left)/negative (right) 44 | - HALT (with exit code) 45 | - Load constant: LDC 46 | - Load/Store memory: LD+, ST+ (address into register, register to address, and inc/dec) 47 | - Conditional: CP? (A=B if C) 48 | - ALU: ADD, SUB, MUL, DIV 49 | - Bitwise: NAND, SHL, SHR 50 | - I/O: char IN, OUT, disk READ, WRITE 51 | 52 | ## F18 53 | 54 | - Transfer: 55 | - jump/call/execute/return, next/unext, conditional if/-if 56 | - `;` (return), `ex` (execute, swap P and R), `(jump)`, `(call)` 57 | - `next` (loop to address, dec R), `unext` (micronext, loop within I, dec R) 58 | - `if` (jump if T=0), `-if` (minus-if, jump if T>=0) 59 | - Data: 60 | - fetch/store via P/A/B (A includes incrementing version) 61 | - `@p` (fetch-p, inc), `@+` (fetch-plus, via A, inc), `@b` (fetch-b), `@` (fetch, via A) 62 | - `!p` (store-p, inc), `!+` (store-plus, via A, inc), `!b` (store-b), `!` (store, via A) 63 | - ALU: 64 | - add/mul (step), bitwise shift/not/and/or, stack, get/set A/B (B is write-only), NOP 65 | - `+*` (multiply-step), `2*` (two-star), `2/` (two-slash), `-` (not), `+` (plus) 66 | - `and`, `or` (exclusive) 67 | - `drop`, `dup`, `over`, `pop` (R), `push` (R) 68 | - `a`, `b!` (b-store, into B), `a!` (a-store, into A), 69 | - `.` (nop) 70 | 71 | ## SM16 72 | 73 | - P register points to memory (16-bit aligned) or port (negative) 74 | 75 | | Cell | Instruction | Notes | 76 | | ---- | ----------- | ------- | 77 | | 0000 | `@` | fetch | 78 | | 0001 | `!` | store | 79 | | 0010 | `@p` | fetch-p | 80 | | 0011 | `!p` | store-p | 81 | | 0100 | `push` | >r | 82 | | 0101 | `pop` | r> | 83 | | 0110 | `swap` | | 84 | | 0111 | `over` | | 85 | | 1000 | `drop` | | 86 | | 1001 | `dup` | | 87 | | 1010 | `next` | | 88 | | 1011 | `shift` | | 89 | | 1100 | `nand` | | 90 | | 1101 | `+` | | 91 | | 1110 | `*` | | 92 | | 1111 | `.` (nop) | | 93 | 94 | | Last | Cell | Instruction | Notes | 95 | | ---- | ---- | ----------- | ----- | 96 | | | 0 | `call` | s15 | 97 | | 00 | 1 | `jump` | s13 | 98 | | 01 | 1 | `?jump` | s13 | 99 | | 10 | 1 | `return` | | 100 | | 011 | 1 | `repeat` | | 101 | | 111 | 1 | `.` (nop) | | 102 | 103 | Examples: 104 | 105 | - Load 10 cells into memory and execute 106 | - @p @p push . 107 | - 0 (value) 108 | - 10 (value) 109 | - @p over ! unext 110 | - drop . . . 111 | - 0000000000000001 (0 jump) 112 | 113 | - Print alphabet 114 | - Humm... how to output to a port?! 115 | 116 | ## Brief VM 117 | 118 | - No leading bit is a 16-bit call 119 | - Call followed by return is tail optimized 120 | - Lower 7-bits is instruction 121 | - Instructions: 122 | - `push` / `pop` / `peek` 123 | - `(return)` 124 | - `c@` / `c!` / `@` / `!` / `+` 125 | - `-` / `*` / `/` / `mod` / `neg` 126 | - `and` / `or` / `xor` / `not` / `shift` 127 | - `=` / `<>` / `>` / `>=` / `<` / `<=` 128 | - `1+` / `1-` 129 | - `drop` / `dup` / `swap` / `pick` / `roll` / `clear` 130 | - `forget` 131 | - `call` 132 | - `choice` / `if` 133 | - `reset` 134 | 135 | ## SM16 II 136 | 137 | - 32K memory 138 | - 16-cell data/return stacks (circular) 139 | - 127 byte codes (high bit set) 140 | - 15-bit calls (followed by return, TCO) 141 | - Protocol: prefix (2-bytes, execute flag+len) n-bytes -------------------------------------------------------------------------------- /hardware/register_v0/bootstrap.f: -------------------------------------------------------------------------------- 1 | ( bootstrap remainder of kernel ) 2 | ( load into machine running kernel image ) 3 | 4 | header : compile header compile ; ( magic! ) 5 | 6 | ( assembler ) 7 | 8 | : x 2 ; ( shared by kernel ) 9 | : d 3 ; ( dictionary pointer - shared by kernel ) 10 | : lnk 4 ; ( link pointer - shared by kernel ) 11 | : zero 5 ; ( shared by kernel ) 12 | : y 18 ; ( beyond registers in kernel ) 13 | : z 19 ; 14 | 15 | : [ interact ; immediate 16 | : ] compile ; 17 | 18 | : cp, 6 c, c, c, ; 19 | : popxy popx [ x y cp, ] popx ; 20 | : popxyz popxy [ y z cp, x y cp, ] popx ; 21 | : pushxy pushx [ y x cp, ] pushx ; 22 | 23 | : xor, 18 c, c, c, c, ; 24 | : swap popxy [ x y x xor, x y y xor, x y x xor, ] pushxy ; 25 | 26 | : halt, 0 c, ; 27 | : ldc, 1 c, , c, ; 28 | : ld, 2 c, c, c, ; 29 | : st, 3 c, c, c, ; 30 | : ldb, 4 c, c, c, ; 31 | : stb, 5 c, c, c, ; 32 | ( cp, defined above ) 33 | : in, 7 c, c, ; 34 | : out, 8 c, c, ; 35 | : inc, 9 c, c, c, ; 36 | : dec, 10 c, c, c, ; 37 | : add, 11 c, c, c, c, ; 38 | : sub, 12 c, c, swap c, c, ; 39 | : mul, 13 c, c, c, c, ; 40 | : div, 14 c, c, swap c, c, ; 41 | : mod, 15 c, c, swap c, c, ; 42 | : and, 16 c, c, c, c, ; 43 | : or, 17 c, c, c, c, ; 44 | ( xor defined above ) 45 | : not, 19 c, c, c, ; 46 | : shl, 20 c, c, swap c, c, ; 47 | : shr, 21 c, c, swap c, c, ; 48 | : beq, 22 c, , c, c, ; 49 | : bne, 23 c, , c, c, ; 50 | : bgt, 24 c, , swap c, c, ; 51 | : bge, 25 c, , swap c, c, ; 52 | : blt, 26 c, , swap c, c, ; 53 | : ble, 27 c, , swap c, c, ; 54 | : jump, 28 c, , ; 55 | : call, 29 c, , ; 56 | : exec, 30 c, c, ; 57 | : ret, 31 c, ; 58 | : read, 32 c, c, c, c, ; 59 | : write, 33 c, c, c, c, ; 60 | 61 | ( instruction words ) 62 | 63 | : + popxy [ x y x add, ] pushx ; 64 | : - popxy [ x y x sub, ] pushx ; 65 | : * popxy [ x y x mul, ] pushx ; 66 | : / popxy [ x y x div, ] pushx ; 67 | : mod popxy [ x y x mod, ] pushx ; 68 | : 2* popxy [ x y x shl, ] pushx ; 69 | : 2/ popxy [ x y x shr, ] pushx ; 70 | : and popxy [ x y x and, ] pushx ; 71 | : or popxy [ x y x or, ] pushx ; 72 | : xor popxy [ x y x xor, ] pushx ; 73 | : invert popx [ x x not, ] pushx ; 74 | : 1+ popx [ x x inc, ] pushx ; 75 | : 1- popx [ x x dec, ] pushx ; 76 | : execute popx [ x exec, ] ; 77 | : halt [ halt, ] ; 78 | 79 | ( stack manipulation ) 80 | 81 | : drop popx ; 82 | : dup popx pushx pushx ; 83 | : over popxy pushx pushx [ y x cp, ] pushx swap ; 84 | : nip swap drop ; 85 | : tuck swap over ; 86 | : -rot swap popxy pushx [ y z cp, ] swap [ z x cp, ] pushx ; 87 | : rot -rot -rot ; 88 | 89 | ( vocabulary ) 90 | 91 | : true -1 ; 92 | : false 0 ; 93 | 94 | : key [ x in, ] pushx ; 95 | : emit popx [ x out, ] ; 96 | : lf 10 emit ; 97 | : cr 13 emit ; 98 | : space 32 emit ; 99 | 100 | : @ popx [ x x ld, ] pushx ; 101 | : c@ popx [ x x ldb, ] pushx ; 102 | : ! popxy [ x y st, ] ; 103 | : c! popxy [ x y stb, ] ; 104 | 105 | : here [ d x cp, ] pushx ; 106 | 107 | : magic [ x 5 ldc, lnk x st, x 1 ldc, d x st, ] ; ( store at magic address for image ) 108 | : read popxyz [ x y z read, ] ; 109 | : write popxyz [ x y z write, ] ; 110 | 111 | : constant header literal ret, ; ( e.g. 123 constant foo -> foo3 . 0 LDC 123 n CALL &pushn RET ) 112 | : variable header here 8 + literal ret, 0 , ; ( e.g. variable foo -> foo3 . 0 LDC n CALL &pushn RET 0 ) 113 | 114 | : allot popx [ x d d add, ] ; 115 | 116 | : if [ ' popx literal ] call, here 1 + zero x 0 beq, ; immediate 117 | : else here 1 + 0 jump, swap here swap ! ; immediate 118 | : then here swap ! ; immediate 119 | 120 | : _dp+ here 8 + ; ( * ) ( over BRANCH addr x y CALL invert ) 121 | : = popxy 0 [ x y _dp+ bne, ] invert ; 122 | : <> popxy 0 [ x y _dp+ beq, ] invert ; 123 | : > popxy 0 [ x y _dp+ ble, ] invert ; 124 | : < popxy 0 [ x y _dp+ bge, ] invert ; 125 | : >= popxy 0 [ x y _dp+ blt, ] invert ; 126 | : <= popxy 0 [ x y _dp+ bgt, ] invert ; 127 | 128 | : negate -1 * ; 129 | : abs dup 0 < if negate then ; 130 | : 2dup over over ; 131 | : /mod 2dup / -rot mod ; 132 | 133 | : _.d 10 /mod swap ; 134 | : _.z char 0 + emit ; 135 | : _.e dup if swap _.z else swap dup 0 = if drop else _.z drop true then then ; 136 | : num dup 0 < if char - emit then abs _.d _.d _.d _.d _.d drop false _.e _.e _.e _.e drop _.z ; 137 | : . num cr lf ; 138 | 139 | : begin here ; immediate 140 | : until [ ' popx literal ] call, zero x rot beq, ; immediate 141 | : again [ ' popx literal ] call, jump, ; immediate 142 | 143 | here 144 | 64 allot 145 | variable r r ! 146 | 147 | : >r r @ ! r @ 2 + ( * ) r ! ; 148 | : r> r @ 2 - ( * ) r ! r @ @ ; 149 | : r@ r @ 2 - ( * ) @ ; 150 | 151 | : _do swap >r >r ; 152 | : do [ ' _do literal ] call, here ; immediate 153 | : _loop0 r> 1+ dup >r r @ 4 ( * ) - @ >= popx ; 154 | : _loop1 r> r> drop drop ; 155 | : loop [ ' _loop0 literal ] call, zero x rot beq, [ ' _loop1 literal ] call, ; immediate 156 | 157 | : i r @ 2 - ( * ) @ ; 158 | : j r @ 6 - ( * ) @ ; 159 | 160 | : [: here 10 + ( * ) ( past LIT . . CALL . JUMP . ) literal here 1 + 0 jump, ( jump address field ) ; immediate 161 | : :] ret, here swap ! ; immediate 162 | : call popx [ x exec, ] ; 163 | -------------------------------------------------------------------------------- /hardware/register_v2/turtle-geometry-book.fs: -------------------------------------------------------------------------------- 1 | \ --- turtle geometry adapter --- 2 | 3 | variable pen true pen ! 4 | : pendown true pen ! ; 5 | : penup false pen ! ; 6 | 7 | : start clear home pendown ; \ TODO redefine in terms of old start 8 | 9 | : forward pen @ if move else jump then ; 10 | : back 180 turn forward 180 turn ; 11 | : left turn ; 12 | : right -1 * turn ; 13 | 14 | : iterate 0 postpone literal postpone do ; immediate 15 | 16 | \ --- turtle geometry examples --- 17 | 18 | : turtle 14 19 | plot dup 2/ jump 20 | 166 turn dup move 21 | 104 turn dup 2/ move \ really 0.5176 * 22 | 104 turn dup move 23 | -14 turn 2/ negate jump ; 24 | 25 | : p4 26 | start 27 | 50 forward turtle 28 | 90 right 75 forward 45 left turtle 29 | 50 back turtle 30 | 45 left penup 50 forward turtle 31 | show ; 32 | 33 | : square0 34 | 50 forward 90 right 35 | 50 forward 90 right 36 | 50 forward 90 right 37 | 50 forward 90 right ; 38 | 39 | : square1 40 | 4 iterate 41 | 50 forward 90 right 42 | loop ; 43 | 44 | : square ( size -- ) 45 | 4 iterate 46 | dup forward 90 right 47 | loop drop ; 48 | 49 | : p5 start -80 -30 go square0 -40 0 go square1 20 20 go 60 0 do i square 15 +loop show ; 50 | 51 | : square-piece ( size -- ) 52 | forward 90 right ; 53 | 54 | : square ( size -- ) 55 | 4 iterate 56 | dup square-piece 57 | loop drop ; 58 | 59 | : rectangle ( side1 side2 -- ) 60 | 2 iterate 61 | 2dup square-piece square-piece 62 | loop 2drop ; 63 | 64 | : rectangle ( side1 side2 -- ) 65 | 2dup 2 iterate 66 | square-piece square-piece 67 | loop ; 68 | 69 | : p6 start -80 -40 go 20 square 20 0 go 20 40 rectangle show ; 70 | 71 | : try-angle ( size -- ) 72 | 3 iterate 73 | dup forward 60 right 74 | loop drop ; 75 | 76 | : triangle ( size -- ) 77 | 3 iterate 78 | dup forward 120 right 79 | loop drop ; 80 | 81 | : p7 start -80 0 go 30 try-angle turtle home 30 triangle show ; 82 | 83 | : house0 ( size -- ) 84 | dup square triangle ; 85 | 86 | : house ( size -- ) 87 | dup square dup forward 30 right triangle ; 88 | 89 | : p8 start -80 0 go 30 house0 home 30 house show ; 90 | 91 | : thing 92 | 30 forward 90 right 93 | 30 forward 90 right 94 | 10 forward 90 right 95 | 10 forward 90 right 96 | 30 forward 90 right 97 | 8 forward 90 right 98 | 8 forward 90 right 99 | 10 forward ; 100 | 101 | : things0 4 iterate thing loop ; 102 | 103 | : things1 9 iterate thing 10 right 10 forward loop ; 104 | 105 | : things2 8 iterate thing 45 left 30 forward loop ; 106 | 107 | : p9 start thing show 108 | start things0 show 109 | start things1 show 110 | start things2 show ; 111 | 112 | : circle 360 iterate 1 forward 1 right loop ; 113 | 114 | : arcr ( r deg -- ) 6 / iterate dup forward 6 right loop drop ; \ 6x step, tighter 115 | : arcl ( r deg -- ) 6 / iterate dup forward 6 left loop drop ; 116 | 117 | : p10 start -60 0 go circle home 4 90 arcr home 4 90 arcl show ; 118 | 119 | : circles 9 iterate 4 360 arcr 40 right loop ; 120 | 121 | : petal ( size -- ) 122 | dup 60 arcr 120 right 123 | 60 arcr 120 right ; 124 | 125 | : flower ( size -- ) 126 | 6 iterate 127 | dup petal 60 right 128 | loop drop ; 129 | 130 | : ray ( r -- ) 131 | 2 iterate 132 | dup 90 arcl 133 | dup 90 arcr 134 | loop drop ; 135 | 136 | : sun ( size -- ) 137 | 9 iterate 138 | dup ray 139 | 160 right 140 | loop drop ; 141 | 142 | : p12 start circles show 143 | start 8 flower show 144 | start 48 -65 go 3 sun show ; 145 | 146 | : npoly ( angle side n -- ) 147 | iterate 148 | 2dup forward right 149 | loop 2drop ; 150 | 151 | : poly ( angle side -- ) 360 over / npoly ; 152 | 153 | : p16 154 | start -60 -20 go 72 70 poly show 155 | start -30 -40 go 144 120 5 npoly show 156 | start -70 0 go 1 1 poly show 157 | start -60 -20 go 60 60 poly show 158 | start -30 -40 go 135 120 8 npoly show 159 | start -30 -40 go 108 100 10 npoly show ; 160 | 161 | : new-npoly ( angle side n -- ) 162 | iterate 163 | 2dup forward right 164 | 2dup forward 2* right 165 | loop 2drop ; 166 | 167 | : p17 168 | start -50 -20 go 30 50 4 new-npoly show 169 | start -20 0 go 144 40 5 new-npoly show 170 | start -60 -40 go 45 70 8 new-npoly show 171 | start -30 60 go 125 14 25 new-npoly show ; 172 | 173 | : polyspi ( inc angle side -- ) 174 | valid? if 175 | 2dup forward right plot \ plot to show vertex when penup 176 | 2 pick + tail-recurse 177 | else 2drop drop then ; 178 | 179 | : p18 180 | start 2 95 2 polyspi show 181 | start 4 90 4 polyspi show 182 | start 6 120 6 polyspi show 183 | start 3 117 3 polyspi show 184 | ; 185 | 186 | : p19 187 | start penup 2 95 2 polyspi show 188 | start penup 1 95 1 polyspi show 189 | start penup 1 117 1 polyspi show 190 | start penup 1 111 1 polyspi show 191 | ; 192 | 193 | : inspi ( inc angle side count -- ) 194 | 0 do 195 | 2dup forward right 196 | -rot over + rot \ tail-recurse 197 | loop 198 | 2drop drop 199 | ; 200 | 201 | : p20 202 | start 7 1 5 10000 inspi show 203 | start -110 70 go 20 2 2 20000 inspi show 204 | ; 205 | 206 | : all demo 207 | p4 p5 p6 p7 p8 p9 p10 p12 p16 p17 208 | p18 p19 209 | p20 210 | ; 211 | all 212 | 213 | bye 214 | -------------------------------------------------------------------------------- /hardware/register_v0/machine.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | 5 | #include 6 | #include 7 | #include 8 | #include 9 | 10 | unsigned char mem[0x8000]; 11 | 12 | void setcell(unsigned short a, short y) 13 | { 14 | extern unsigned char mem[]; 15 | mem[a] = y; 16 | mem[a + 1] = y >> 8; 17 | } 18 | 19 | short getcell(unsigned short a) 20 | { 21 | extern unsigned char mem[]; 22 | return mem[a] | (mem[a + 1] << 8); 23 | } 24 | 25 | void readBlock(short block, short maxsize, short address) 26 | { 27 | char filename[16]; 28 | snprintf(filename, sizeof(filename), "block%d.bin", block); 29 | FILE *file = fopen(filename, "r"); 30 | fseek(file, 0, SEEK_END); 31 | long size = ftell(file); 32 | fseek(file, 0, SEEK_SET); 33 | if (!file || !fread(mem + address, maxsize < size ? maxsize : size, 1, file)) // assumes size+address <= sizeof(mem) 34 | { 35 | printf("Could not open block file.\n"); 36 | } 37 | fclose(file); 38 | } 39 | 40 | void writeBlock(short block, short size, short address) 41 | { 42 | char filename[16]; 43 | snprintf(filename, sizeof(filename), "block%d.bin", block); 44 | FILE *file = fopen(filename, "w"); 45 | if (!file || !fwrite(mem + address, 1, size, file)) 46 | { 47 | printf("Could not write block file.\n"); 48 | } 49 | fclose(file); 50 | } 51 | 52 | int main(void) 53 | { 54 | // Set stdin to non-blocking mode 55 | int flags = fcntl(STDIN_FILENO, F_GETFL, 0); 56 | fcntl(STDIN_FILENO, F_SETFL, flags | O_NONBLOCK); 57 | 58 | short reg[64] = {}; 59 | short rstack[256] = {}; 60 | short* r = rstack; 61 | short pc = 0; 62 | 63 | readBlock(0, SHRT_MAX, 0); 64 | 65 | short x, y, z, v; 66 | 67 | #define NEXT mem[pc++] 68 | #define X x = NEXT; 69 | #define XY X; y = NEXT 70 | #define XYZ XY; z = NEXT; 71 | #define V v = mem[pc] | mem[pc + 1] << 8; pc += 2 72 | #define Rx reg[x] 73 | #define Ry reg[y] 74 | #define Rz reg[z] 75 | #define OUT wprintf(L"%lc", Rx); fflush(stdout) 76 | #define IN Rx = getc(stdin); if (feof(stdin)) { clearerr(stdin); } 77 | 78 | setlocale(LC_ALL, ""); 79 | 80 | while (1) 81 | { 82 | //printf("%04X -> %02X %02X %02X %02X %02X %02X %02X %02X %02X %02X \n", pc, mem[pc], mem[pc+1], mem[pc+2], mem[pc+3], mem[pc+4], mem[pc+5], mem[pc+6], mem[pc+7], mem[pc+8], mem[pc+9]); 83 | switch(NEXT) 84 | { 85 | case 0: return 0; // halt 86 | case 1: V; X; Rx = v; break; // ldc (x = v) // TODO: swap x <-> v 87 | case 2: XY; Rx = getcell(Ry); break; // ld (x = m[y]) 88 | case 3: XY; setcell(Rx, Ry); break; // st (m[x] = y) 89 | case 4: XY; Rx = mem[Ry]; break; // ldb (x = m[y]) 90 | case 5: XY; mem[Rx] = Ry; break; // stb (m[x] = y) 91 | case 6: XY; Rx = Ry; break; // cp (x = y) 92 | case 7: X; IN; break; // in (x = getc()) 93 | case 8: X; OUT; break; // out (putc(x)()) 94 | case 9: XY; Rx = Ry + 1; break; // inc (x = ++y) 95 | case 10: XY; Rx = Ry - 1; break; // dec (x = --y) 96 | case 11: XYZ; Rx = Ry + Rz; break; // add (x = y + z) 97 | case 12: XYZ; Rx = Ry - Rz; break; // sub (x = y - z) 98 | case 13: XYZ; Rx = Ry * Rz; break; // mul (x = y * z) 99 | case 14: XYZ; Rx = Ry / Rz; break; // div (x = y / z) 100 | case 15: XYZ; Rx = Ry % Rz; break; // mod (x = y % z) 101 | case 16: XYZ; Rx = Ry & Rz; break; // and (x = y & z) 102 | case 17: XYZ; Rx = Ry | Rz; break; // or (x = y | z) 103 | case 18: XYZ; Rx = Ry ^ Rz; break; // xor (x = y ^ z) 104 | case 19: XY; Rx = ~Ry; break; // not (x = ~y) 105 | case 20: XYZ; Rx = Ry << Rz; break; // shl (x = y << z) 106 | case 21: XYZ; Rx = Ry >> Rz; break; // shr (x = y >> z) 107 | case 22: V; XY; if (Rx == Ry) pc = v; break; // beq (branch if x == y) 108 | case 23: V; XY; if (Rx != Ry) pc = v; break; // bne (branch if x != y) 109 | case 24: V; XY; if (Rx > Ry) pc = v; break; // bgt (branch if x > y) 110 | case 25: V; XY; if (Rx >= Ry) pc = v; break; // bge (branch if x >= y) 111 | case 26: V; XY; if (Rx < Ry) pc = v; break; // blt (branch if x < y) 112 | case 27: V; XY; if (Rx <= Ry) pc = v; break; // ble (branch if x <= y) 113 | case 28: V; pc = v; break; // jump (pc = v) 114 | case 29: V; *(r++) = pc; pc = v; break; // call (jsr(v)) 115 | case 30: X; *(r++) = pc; pc = Rx; break; // exec (jsr(x)) 116 | case 31: pc = *(--r); break; // return (ret) 117 | case 32: XYZ; readBlock(Rx, Ry, Rz); break; // read 118 | case 33: XYZ; writeBlock(Rx, Ry, Rz); break; // write 119 | default: 120 | printf("Invalid instruction! (pc=%04X [%04X])\n", pc - 2, getcell(pc - 2)); 121 | return 1; 122 | } 123 | } 124 | 125 | return 0; 126 | } 127 | -------------------------------------------------------------------------------- /hardware/register_v1/machine.c: -------------------------------------------------------------------------------- 1 | // v2 2 | #define _VERBOSE 3 | 4 | #include 5 | #include 6 | #include 7 | #include 8 | #include 9 | #include 10 | #include 11 | 12 | short reg[16] = {}; 13 | unsigned char mem[0x8000]; 14 | 15 | void readBlock(short block, short maxsize, short address) 16 | { 17 | char filename[16]; 18 | snprintf(filename, sizeof(filename), "block%d.bin", block); 19 | FILE *file = fopen(filename, "r"); 20 | fseek(file, 0, SEEK_END); 21 | long size = ftell(file); 22 | fseek(file, 0, SEEK_SET); 23 | if (!file || !fread(mem + address, maxsize < size ? maxsize : size, 1, file)) // assumes size+address <= sizeof(mem) 24 | { 25 | printf("Could not open block file.\n"); 26 | } 27 | fclose(file); 28 | } 29 | 30 | void writeBlock(short block, short size, short address) 31 | { 32 | char filename[16]; 33 | snprintf(filename, sizeof(filename), "block%d.bin", block); 34 | FILE *file = fopen(filename, "w"); 35 | if (!file || !fwrite(mem + address, 1, size, file)) 36 | { 37 | printf("Could not write block file.\n"); 38 | } 39 | fclose(file); 40 | } 41 | 42 | #define NEXT mem[reg[0]++] 43 | #define LOW(b) b & 0x0F 44 | #define HIGH(b) LOW(b >> 4); 45 | 46 | int main(void) 47 | { 48 | fcntl(STDIN_FILENO, F_SETFL, fcntl(STDIN_FILENO, F_GETFL, 0) | O_NONBLOCK); // Set stdin to non-blocking mode 49 | setlocale(LC_ALL, ""); // support unicode 50 | readBlock(0, SHRT_MAX, 0); 51 | 52 | while (1) 53 | { 54 | unsigned char c = NEXT; 55 | unsigned char j = NEXT; 56 | unsigned char i = HIGH(c); 57 | unsigned char x = LOW(c); 58 | unsigned char y = HIGH(j); 59 | unsigned char z = LOW(j); 60 | switch(i) 61 | { 62 | case 0: // HALT 63 | #ifdef VERBOSE 64 | printf("HALT %2i\n", x); 65 | #endif 66 | return reg[x]; 67 | case 1: // LDC 68 | #ifdef VERBOSE 69 | printf("LDC %2i=%2i ", x, ((y << 4) | z)); 70 | #endif 71 | reg[x] = (signed char)((y << 4) | z); 72 | break; 73 | case 2: // LD+ 74 | #ifdef VERBOSE 75 | printf("LD+ %2i=[%2i] +%2i ", z, y, x); 76 | #endif 77 | reg[z] = (mem[reg[y]] | (mem[reg[y] + 1] << 8)); 78 | reg[y] += reg[x]; 79 | break; 80 | case 3: // ST+ 81 | #ifdef VERBOSE 82 | printf("ST+ [%2i]=%2i +%2i ", z, y, x); 83 | #endif 84 | mem[reg[z]] = reg[y]; // truncated to byte 85 | mem[reg[z] + 1] = (reg[y] >> 8); // truncated to byte 86 | reg[z] += reg[x]; 87 | break; 88 | case 4: // CP? 89 | #ifdef VERBOSE 90 | printf("CP? %2i=%2i if %2i=0 ", z, y, x); 91 | #endif 92 | if (reg[x] == 0) reg[z] = reg[y]; 93 | break; 94 | case 5: // ADD 95 | #ifdef VERBOSE 96 | printf("ADD %2i=%2i+%2i ", z, y, x); 97 | #endif 98 | reg[z] = reg[y] + reg[x]; 99 | break; 100 | case 6: // SUB 101 | #ifdef VERBOSE 102 | printf("SUB %2i=%2i-%2i ", z, y, x); 103 | #endif 104 | reg[z] = reg[y] - reg[x]; 105 | break; 106 | case 7: // MUL 107 | #ifdef VERBOSE 108 | printf("MUL %2i=%2i*%2i ", z, y, x); 109 | #endif 110 | reg[z] = reg[y] * reg[x]; 111 | break; 112 | case 8: // DIV 113 | #ifdef VERBOSE 114 | printf("DIV %2i=%2i/%2i ", z, y, x); 115 | #endif 116 | reg[z] = reg[y] / reg[x]; 117 | break; 118 | case 9: // NAND 119 | #ifdef VERBOSE 120 | printf("NAND %2i=%2i&%2i ", z, y, x); 121 | #endif 122 | reg[z] = ~(reg[y] & reg[x]); 123 | break; 124 | case 10: // SHL 125 | #ifdef VERBOSE 126 | printf("SHL %2i=%2i<<%2i ", z, y, x); 127 | #endif 128 | reg[z] = reg[y] << reg[x]; 129 | break; 130 | case 11: // SHR 131 | #ifdef VERBOSE 132 | printf("SHR %2i=%2i>>%2i ", z, y, x); 133 | #endif 134 | reg[z] = reg[y] >> reg[x]; 135 | break; 136 | case 12: // IN 137 | #ifdef VERBOSE 138 | printf("IN ->%2i ", x); 139 | #endif 140 | reg[0]--; 141 | reg[x] = getc(stdin); 142 | if (feof(stdin)) { clearerr(stdin); } 143 | break; 144 | case 13: // OUT 145 | #ifdef VERBOSE 146 | printf("OUT %2i-> ", x); 147 | #endif 148 | reg[0]--; 149 | wprintf(L"%lc", reg[x]); 150 | fflush(stdout); 151 | break; 152 | case 14: // READ 153 | #ifdef VERBOSE 154 | printf("READ ->%2i (%2i, %2i) ", z, y, x); 155 | #endif 156 | readBlock(reg[z], reg[y], reg[x]); 157 | break; 158 | case 15: // WRITE 159 | #ifdef VERBOSE 160 | printf("WRITE %2i-> (%2i, %2i) ", z, y, x); 161 | #endif 162 | writeBlock(reg[z], reg[y], reg[x]); 163 | break; 164 | default: 165 | printf("Invalid instruction! (%i)\n", i); 166 | return 1; 167 | } 168 | #ifdef VERBOSE 169 | printf("pc:%i 1:%i 2:%i 3:%i 4:%i 5:%i 6:%i 7:%i 8:%i 9:%i 10:%i 11:%i 12:%i 13:%i 14:%i 15:%i m100:%2i m101:%2i m102:%2i\n", reg[0], reg[1], reg[2], reg[3], reg[4], reg[5], reg[6], reg[7], reg[8], reg[9], reg[10], reg[11], reg[12], reg[13], reg[14], reg[15], mem[100], mem[101], mem[102]); 170 | #endif 171 | } 172 | 173 | return 0; // TODO: not needed (halt is the only way out) 174 | } -------------------------------------------------------------------------------- /library/pixels/readme.md: -------------------------------------------------------------------------------- 1 | # Braille Pixel Library 2 | 3 | Console pixel graphics library using [Unicode braille characters (`0x2800`-`0x28FF`)](http://www.unicode.org/charts/PDF/U2800.pdf). 4 | 5 | The canvas is 160×160. You may `clear` it, `set` and `reset` pixels, and `show` it. 6 | 7 | To test the [`pixels`](./pixels.f) library: [`sh ./test.sh`](./test.sh) 8 | 9 | You should see this little guy (assuming Unicode font supporting Braille and UTF-8 terminal): 10 | 11 | ```text 12 | ⠀⠀⠀ ⠀⣀⣠⠤⢤⠤⣀⠀⠀ ⢀⠔⠊⡉⠑⡄ 13 | ⠀⠀⢀⠔⡫⡊⠉⡢⡊⠉⡢⡋⣢⣀⡎⠀⠀⠠⡤⠃ 14 | ⠀⡔⠫⡹⡀⡸⡹⡀⡸⣉⠔⠉⢀⡰⠁⢀⠔⠉ 15 | ⠀⠑⣄⣈⣉⣉⣉⣉⣉⣀⢤⠪⢅⣀⢔⠏ 16 | ⠀⢎⡠⠚⠢⠤⠤⡤⠃⢀⠮⠤⠤⢖⠑⢢ 17 | ⠀⠀⠀⠀⠀ ⠀⠑⠒⠁⠀⠀ ⠀ ⠉⠁ 18 | ``` 19 | 20 | ## Vocabulary 21 | 22 | | Word | Signature | Description | 23 | | -------- | --------- | ---------------- | 24 | | `width` | -n | Canvas width | 25 | | `height` | -n | Canvas height | 26 | | `clear` | - | Clear canvas | 27 | | `set` | xy- | Set canvas dot | 28 | | `reset` | xy- | Reset canvas dot | 29 | | `show` | - | Display canvas | 30 | 31 | ## Walkthrough 32 | 33 | The idea is to use a range of Braille Unicode characters to each represent 2×4 pixels. We'll have a 160×160 pixel canvas, made from 80×20 characters. We can use this to draw interesting things in the console. 34 | 35 | ```forth 36 | 160 constant width 37 | 160 constant height 38 | 39 | width 2 / constant columns 40 | width height * 8 / constant size 41 | ``` 42 | 43 | We define the canvas `width` and `height`, and can compute the `columns` and total number of characters (`size`). These constants are computed once at _compile time_ as opposed to say `: columns width 2 / ;`. 44 | 45 | ```forth 46 | : clear size 0 do 10240 i ! loop ; 47 | ``` 48 | 49 | A word to `clear` the canvas fill each cell with the Unicode value of an empty Braille cell (`10240`). This should be called before drawing. 50 | 51 | ```forth 52 | : set cell-mask or swap ! ; 53 | : reset cell-mask swap invert and swap ! ; 54 | ```` 55 | 56 | We'll be using a `cell-mask` word, which well look at in a moment, that takes an x, y pair and returns the cell, the mask and the current value at the cell. We can `set` or `reset` individual dots. To `set`, we `or` the mask with the current value. To `reset`, we invert the mask (`invert`), then `and` it with the current value. In both cases we then store the value in the cell. 57 | 58 | Now to build up to explaining `cell-mask`: 59 | 60 | ```forth 61 | ( init dot masks ) 62 | : init-masks 8 0 do size i + ! loop ; 63 | 128 64 32 4 16 2 8 1 init-masks 64 | ``` 65 | 66 | Here we've stored a table of dot mask values just beyond the canvas buffer (at `size`). We push the table values, then iterate eight times, poking them into memory. These values will be used ask masks to build each of the eight dots in a single Braille character. 67 | 68 | The reason for creating a word (`init-masks`) for this because the behavior of `do ... loop` outside of a definition is undefined in some Forths. Though it works in the Python interpreter, it may not work in future Forths we'll be creating. 69 | 70 | ```forth 71 | : cell 4 / floor columns * swap 2 / floor + ; 72 | ``` 73 | 74 | Each Braille character cell contains 2×4 dots. We can compute the memory `cell` in which a dot on the canvas falls, given the x and y coordinates, by dividing y by 4 and adding the number of `columns` (jumping by _rows_), then add to this x divided by 2 (the column of x). 75 | 76 | For example, `1 3 cell` returns `0` because the dot falls on the bottom right corner of the first cell. However if we move to the right, `2 3 cell` returns `1`; the bottom left corner of the 2nd cell. Moving down, `2 4 cell` returns `81`; the top left corner of the second cell on the second 80-character row. 77 | 78 | ```forth 79 | : mask 4 mod 2 * swap 2 mod + size + @ ; 80 | ``` 81 | 82 | To look up the `mask` value we mod the x coordinate by 2 and the y coordinate by 4 (2×4 dots per cell), and look in the table we built just past the canvas memory (`size +`). 83 | 84 | ```forth 85 | : cell-mask 2dup cell -rot mask over @ ; 86 | ``` 87 | 88 | To get the cell and mask value, we can duplicate the pair of x and y coordinates with `2dup` (defined in the prelude as simply `over over`), get the `cell` of one pair, rotate that out of the way and get the `mask` of the duplicate pair. Finally we fetch the current value at the cell with `over @`. 89 | 90 | 91 | ```forth 92 | : show 93 | size 0 do 94 | i columns mod 0 = if 10 emit then ( newline as appropriate ) 95 | i @ emit 96 | loop ; 97 | ``` 98 | 99 | The above `clear`, `set` and `reset` words don't display anything on the screen. They just manipulate the buffer. To `show` the buffer, we walk it and emit the values, while emitting a newline (`10`) after each 80-character column. 100 | 101 | ## Turtle Turtle 102 | 103 | Before we get into proper [turtle graphics](../turtle/), let's at least draw a graphic of a turtle. We'll start by making a mechanism to draw from bitmaps in code. 104 | 105 | ```forth 106 | variable x variable y 107 | 108 | : start clear 0 x ! 0 y ! ; 109 | : | 0 do 35 = if x @ y @ set then 1 x +! loop 0 x ! 1 y +! ; 110 | ``` 111 | 112 | The `+1` used above comes from the prelude. It adds and stores a value in a variable (defined as `: +! dup @ rot + swap ! ;`). For example, `1 x +!` increments the value stored in `x`. 113 | 114 | The `start` word clears the canvas and initializes the `x`/`y` coordinates. The `|` word expects to have a sequence of numbers on the stack and sets dots for each `35` encountered, which is the ASCII for a `#` character. The sequence should be followed by a number indicating its length. 115 | 116 | Remember the `sym` word that deconstructs a token into its ASCII values followed by the length? Perfect! `sym _#_#_` places `95 35 95 35 95 5` on the stack; a `35` for each `#` and the length we need. The `|` work takes this and sets the dots accordingly. 117 | 118 | ```forth 119 | start 120 | sym _#_#_ | 121 | sym _#_#_ | 122 | sym #___# | 123 | sym _###_ | 124 | show 125 | ``` 126 | 127 | Showing this tiny happy face in a few Braille characters. 128 | 129 | ```text 130 | ⢜⣘⠄ 131 | ``` 132 | 133 | In [test.f](./test.f) is a our turtle. 134 | 135 | ```forth 136 | : turtle start 137 | sym ```````````````````````````````####`` | 138 | sym `````````````````````````````##````#` | 139 | sym ```````````#######``````````#```````# | 140 | sym ````````####```#``##```````#````#```# | 141 | sym ``````##`###```###``##`````#````````# | 142 | sym `````##`#```#`#```#`#`#```#`````````# | 143 | sym ````#``#`````#`````#```#``#``````###` | 144 | sym ```#``#`#```#`#```#`#`#####```````#`` | 145 | sym ``####```###```###``##````#`````##``` | 146 | sym `##``#```#`#```#```#`````#`````#````` | 147 | sym #``#`#```#`#```#``#``````#````#`````` | 148 | sym #```#`#`#`#`#`#`##`````##````#``````` | 149 | sym #````###########`````##`````##``````` | 150 | sym `#``````````````````#``````##```````` | 151 | sym ``#```````````````##`##```#`#```````` | 152 | sym ``################`#```###`#````````` | 153 | sym `#```#````````#````#``````#`````````` | 154 | sym #```###```````#```#`````##`##```````` | 155 | sym #``#```#######````#######````#``````` | 156 | sym `##`````````#````#```````#```#``````` | 157 | sym ````````````#```#`````````###```````` | 158 | sym `````````````###````````````````````` | 159 | show ; 160 | ``` 161 | 162 | ## Next 163 | 164 | Next let's build a [turtle graphics](../turtle/) library with this. -------------------------------------------------------------------------------- /boneyard/interpreter/interpreter.py: -------------------------------------------------------------------------------- 1 | from sys import stdin, stdout, exit, setrecursionlimit 2 | from itertools import takewhile, chain 3 | import operator, math, struct 4 | 5 | setrecursionlimit(100000) 6 | 7 | class Forth: 8 | def __init__(self): 9 | self.index = 0 10 | self.variables = [] 11 | self.memory = bytearray(64 * 1024) 12 | self.stack = [] 13 | self.dictionary = { 14 | '.' : lambda: print(self.pop()), 15 | '.s' : lambda: print(self.stack), 16 | 'nand' : lambda: self.xx_x(lambda x,y: ~(int(x) & int(y))), 17 | '+' : lambda: self.xx_x(operator.add), 18 | '-' : lambda: self.xx_x(operator.sub), 19 | '*' : lambda: self.xx_x(operator.mul), 20 | '/' : lambda: self.xx_x(operator.truediv), 21 | 'mod' : lambda: self.xx_x(operator.mod), 22 | 'cos' : lambda: self.x_x(math.cos), 23 | 'sin' : lambda: self.x_x(math.sin), 24 | 'tan' : lambda: self.x_x(math.tan), 25 | 'acos' : lambda: self.x_x(math.acos), 26 | 'asin' : lambda: self.x_x(math.asin), 27 | 'atan' : lambda: self.x_x(math.atan), 28 | 'floor' : lambda: self.x_x(math.floor), 29 | '=' : lambda: self.xx_b(operator.eq), 30 | '<>' : lambda: self.xx_b(operator.ne), 31 | '>' : lambda: self.xx_b(operator.gt), 32 | '>=' : lambda: self.xx_b(operator.ge), 33 | '<' : lambda: self.xx_b(operator.lt), 34 | '<=' : lambda: self.xx_b(operator.le), 35 | 'lshift' : lambda: self.xx_x(lambda x,y: int(x) << int(y)), 36 | 'rshift' : lambda: self.xx_x(lambda x,y: int(x) >> int(y)), 37 | 'pick' : lambda: self.x_(lambda x: self.stack.append(self.stack[int(-x - 1)])), 38 | 'roll' : lambda: self.x_(lambda x: (self.stack.append(self.stack[int(-x - 1)]), self.stack.pop(int(-x - 2)))), 39 | 'drop' : lambda: self.x_(lambda _: None), 40 | 'variable' : self.variable, 41 | 'constant' : self.constant, 42 | '@' : lambda: self.x_x(self.fetch), 43 | '!' : lambda: self.xx_(self.store), 44 | 'm!' : lambda: self.xx_(self.store), 45 | 'c@' : lambda: self.x_x(lambda x: self.memory[int(x)]), 46 | 'c!' : lambda: self.xx_(self.memoryStoreByte), 47 | 'b@' : lambda: self.x_x(lambda x: self.memory[int(x)]), 48 | 'b!' : lambda: self.xx_(self.memoryStoreByte), 49 | 'write' : lambda: self.xxx_(self.write), 50 | '(' : self.comment, 51 | 'if' : self.doif, 52 | 'else' : self.doelse, 53 | 'then' : self.dothen, 54 | 'do' : lambda: self.xx_(self.doloop), 55 | 'i' : lambda: self.push(self.index), 56 | ':' : self.define, 57 | '\'' : lambda: self._x(self.find), 58 | '[:' : self.anonymous, 59 | 'call' : lambda: self.x_(self.call), 60 | 'emit' : lambda: self.x_(lambda x: stdout.write(chr(int(x)))), 61 | 'sym' : self.symbol, 62 | 'words' : self.words, 63 | 'halt' : lambda: exit(0) } 64 | self.names = [[name] for name in self.dictionary.keys()] 65 | 66 | def pop(self): 67 | if len(self.stack) == 0: 68 | raise Exception("Stack empty") 69 | self.stack, val = self.stack[:-1], self.stack[-1] 70 | return val 71 | 72 | def push(self, x): self.stack.append(x) 73 | def push2(self, xy): 74 | x, y = xy 75 | self.push(x) 76 | self.push(y) 77 | def push3(self, xyz): 78 | x, y, z = xyz 79 | self.push(x) 80 | self.push(y) 81 | self.push(z) 82 | 83 | def flip2(self, f, x, y): return f(y, x) 84 | def flip3(self, f, x, y, z): return f(z, y, x) 85 | def x_x(self, f): self.push(f(self.pop())) 86 | def xx_x(self, f): self.push(self.flip2(f, self.pop(), self.pop())) 87 | def xx_b(self, f): self.push( -1 if self.flip2(f,self.pop(),self.pop()) else 0) 88 | def xx_xx(self, f): self.push2(self.flip2(f, self.pop(), self.pop())) 89 | def x_xx(self, f): self.push2(f(self.pop())) 90 | def xx_xxx(self, f): self.push3(self.flip2(f, self.pop(), self.pop())) 91 | def xxx_xxx(self, f): self.push3(self.flip3(f, self.pop(), self.pop(), self.pop())) 92 | def x_(self, f): f(self.pop()) 93 | def _x(self, f): self.push(f()) 94 | def xx_(self, f): self.flip2(f, self.pop(), self.pop()) 95 | def xxx_(self, f): self.flip3(f, self.pop(), self.pop(), self.pop()) 96 | 97 | def fetch(self, addr): 98 | if addr >= 0: return self.memory[int(addr)] | self.memory[int(addr + 1)] << 8 99 | else: return self.variables[int(-addr) - 1] 100 | 101 | def store(self, val, addr): 102 | if addr >= 0: 103 | self.memory[int(addr)] = int(val) & 0xFF 104 | self.memory[int(addr) + 1] = (int(val) >> 8) & 0xFF 105 | else: self.variables[-addr - 1] = val 106 | 107 | def memoryStoreByte(self, val, addr): self.memory[int(addr)] = int(val) & 0xFF 108 | 109 | def variable(self): 110 | name = next(self.tokens) 111 | index = -len(self.variables) - 1 112 | self.variables.append(0) 113 | self.dictionary[name] = lambda: self.push(index) 114 | 115 | def constant(self): 116 | name = next(self.tokens) 117 | val = self.pop() 118 | self.dictionary[name] = lambda: self.push(val) 119 | 120 | def write(self, block, size, address): 121 | with open(f'block{int(block)}.bin', 'wb') as f: 122 | for m in self.memory[int(address):int(address + size)]: 123 | f.write(struct.pack('B', m)) 124 | 125 | def scan(self): 126 | while True: 127 | for token in self.tokens: 128 | yield token 129 | self.read() 130 | 131 | def comment(self): 132 | while next(self.scan()) != ')': pass 133 | 134 | def doif(self): 135 | if self.pop() == 0: 136 | while not next(self.scan()) in ['else', 'then']: 137 | pass 138 | 139 | def doelse(self): 140 | while next(self.scan()) != 'then': pass 141 | 142 | def dothen(self): pass 143 | 144 | def doloop(self, end, start): 145 | savedIndex = self.index # for loop nesting 146 | savedTokens = self.tokens 147 | code = list(takewhile(lambda t: t != 'loop', self.scan())) 148 | self.index = start 149 | self.tokens = (_ for _ in ()) 150 | while self.index < end: 151 | self.execute(code) 152 | self.index += 1 153 | self.tokens = savedTokens 154 | self.index = savedIndex 155 | 156 | def execute(self, code): 157 | self.tokens = chain(code, self.tokens) 158 | self.evaluate() 159 | 160 | def define(self): 161 | name = next(self.tokens) 162 | code = list(map(lambda w: name if w == 'recurse' else w, takewhile(lambda t: t != ';', self.scan()))) 163 | self.dictionary[name] = (lambda: self.execute(code)) 164 | if not name in self.names: self.names.append([name]) 165 | 166 | def find(self): 167 | name = next(self.tokens) 168 | i = self.names.index([name]) 169 | return i 170 | 171 | def anonymous(self): 172 | code = list(takewhile(lambda t: t != ':]', self.scan())) 173 | self.push(len(self.names)) 174 | self.names.append(code) 175 | 176 | def call(self, i): self.execute(self.names[int(i)]) 177 | 178 | def symbol(self): 179 | name = next(self.tokens) 180 | for c in name[::-1]: self.push(ord(c)) 181 | self.push(len(name)) 182 | 183 | def words(self): 184 | for word in self.dictionary: 185 | print(word, end=' ') 186 | print() 187 | 188 | def read(self): 189 | self.tokens = (token for token in input().split()) 190 | 191 | def evaluate(self): 192 | try: 193 | while True: 194 | token = next(self.tokens) 195 | if token in self.dictionary: 196 | self.dictionary[token]() 197 | else: 198 | self.push(float(token)) 199 | except ValueError: raise Exception(f'{token}?') # not found 200 | except StopIteration: pass # end of tokens 201 | except Exception as error: raise Exception(f'{token} error {error}') 202 | 203 | forth = Forth() 204 | 205 | print("Welcome to PyForth REPL") 206 | while True: 207 | try: 208 | forth.read() 209 | forth.evaluate() 210 | except EOFError: 211 | print('done') 212 | exit() 213 | except Exception as error: print(error) -------------------------------------------------------------------------------- /hardware/register_v0/disassembler.fs: -------------------------------------------------------------------------------- 1 | open System.IO 2 | open System.Text 3 | 4 | let reg = function 5 | | 0uy -> "n" 6 | | 1uy -> "x" 7 | | 2uy -> "d" 8 | | 3uy -> "lnk" 9 | | 4uy -> "m" 10 | | 5uy -> "zero" 11 | | 6uy -> "one" 12 | | 7uy -> "two" 13 | | 8uy -> "ten" 14 | | 9uy -> "true" 15 | | 10uy -> "false" 16 | | 11uy -> "zeroch" 17 | | 12uy -> "rparch" 18 | | 13uy -> "spch" 19 | | 14uy -> "negch" 20 | | 15uy -> "tib" 21 | | 16uy -> "len" 22 | | 17uy -> "len'" 23 | | 18uy -> "nm" 24 | | 19uy -> "p" 25 | | 20uy -> "c" 26 | | 21uy -> "p'" 27 | | 22uy -> "c'" 28 | | 23uy -> "cur" 29 | | 24uy -> "s" 30 | | 25uy -> "ldc" 31 | | 26uy -> "call" 32 | | 27uy -> "ret" 33 | | 28uy -> "comp" 34 | | 29uy -> "sign" 35 | | 30uy -> "y" 36 | | 31uy -> "z" 37 | | r -> "???" 38 | 39 | let hex = sprintf "%04X" 40 | let bytehex = int >> sprintf "%02X" 41 | let valuexy x y = int x ||| (int y <<< 8) 42 | let value x y = valuexy x y |> sprintf "%04X" 43 | 44 | let known = Map.ofList [ 45 | 0x0043, "'skipws" 46 | 0x004B, "'name" 47 | 0x0054, "'skipnone" 48 | 0x0064, "'token" 49 | 0x0070, "'nomatch" 50 | 0x0074, "'compcs" 51 | 0x008B, "'nextw" 52 | 0x008E, "'comp" 53 | 0x00B2, "'find" 54 | 0x00BD, "'error" 55 | 0x00D4, "'negate" 56 | 0x00DA, "'digits" 57 | 0x0100, "'parsenum" 58 | 0x0115, "'pushn" 59 | 0x011D, "'popn" 60 | 0x0125, "'litn" 61 | 0x014A, "'num" 62 | 0x0155, "'exec" 63 | 0x015C, "'compw" 64 | 0x0179, "'word" 65 | 0x0181, "'eval" 66 | 0x018C, "'repl" 67 | 0x02BD, "PAST KERNEL (02BD)"] 68 | 69 | let name labels addr = 70 | match Map.tryFind addr labels with 71 | | Some name -> name 72 | | None -> $"???????????? {hex addr} ???????????? " 73 | 74 | let rec word labels addr nm = function 75 | | len :: l0 :: l1 :: immediate :: t when len <= 32uy -> 76 | if int len <> List.length nm then printfn "UNKNOWN"; disassemble labels addr (List.tail t) 77 | let name' = Encoding.ASCII.GetString(nm |> List.rev |> Array.ofList) 78 | printfn $"---- {name'} -----------------------------" 79 | printfn $"{hex addr} WORD {name'} {bytehex len} {value l0 l1} {bytehex immediate} --> {valuexy l0 l1 |> (fun x -> x + 3) |> name labels}" 80 | let addr' = addr + int len + 1 + 2 + 1 81 | disassemble (Map.add addr' name' labels) addr' t 82 | | c :: t -> word labels addr (c :: nm) t 83 | | [] -> printfn "END" 84 | | t -> printfn "UNKNOWN"; disassemble labels addr (List.tail t) 85 | 86 | and disassemble labels addr = 87 | match Map.tryFind addr labels with 88 | | Some name when name.StartsWith("'") && name <> "'" -> printfn $"---- {name} -----------------------------" 89 | | _ -> () 90 | let nm x y = valuexy x y |> name labels 91 | function 92 | | 0uy :: 0uy :: t -> printfn "EMPTY EMPTY" ; disassemble labels (addr + 2) t 93 | | 0uy :: t -> printfn $"{hex addr} HALT" ; disassemble labels (addr + 1) t 94 | | 1uy :: x :: y :: z :: t -> printfn $"{hex addr} LDC {reg z} = {value x y}" ; disassemble labels (addr + 4) t 95 | | 2uy :: x :: y :: t -> printfn $"{hex addr} LD {reg x} = m[{reg y}]" ; disassemble labels (addr + 3) t 96 | | 3uy :: x :: y :: t -> printfn $"{hex addr} ST m[{reg x}] = {reg y}" ; disassemble labels (addr + 3) t 97 | | 4uy :: x :: y :: t -> printfn $"{hex addr} LDB {reg x} = m[{reg y}]" ; disassemble labels (addr + 3) t 98 | | 5uy :: x :: y :: t -> printfn $"{hex addr} STB m[{reg x}] = {reg y}" ; disassemble labels (addr + 3) t 99 | | 6uy :: x :: y :: t -> printfn $"{hex addr} CP {reg x} = {reg y}" ; disassemble labels (addr + 3) t 100 | | 7uy :: x :: t -> printfn $"{hex addr} IN {reg x} = getc()" ; disassemble labels (addr + 2) t 101 | | 8uy :: x :: t -> printfn $"{hex addr} OUT putc({reg x})" ; disassemble labels (addr + 2) t 102 | | 9uy :: x :: y :: t -> printfn $"{hex addr} INC {reg x} = ++{reg y}" ; disassemble labels (addr + 3) t 103 | | 10uy :: x :: y :: t -> printfn $"{hex addr} DEC {reg x} = --{reg y}" ; disassemble labels (addr + 3) t 104 | | 11uy :: x :: y :: z :: t -> printfn $"{hex addr} ADD {reg x} = {reg y} + {reg z}" ; disassemble labels (addr + 4) t 105 | | 12uy :: x :: y :: z :: t -> printfn $"{hex addr} SUB {reg x} = {reg y} - {reg z}" ; disassemble labels (addr + 4) t 106 | | 13uy :: x :: y :: z :: t -> printfn $"{hex addr} MUL {reg x} = {reg y} * {reg z}" ; disassemble labels (addr + 4) t 107 | | 14uy :: x :: y :: z :: t -> printfn $"{hex addr} DIV {reg x} = {reg y} / {reg z}" ; disassemble labels (addr + 4) t 108 | | 15uy :: x :: y :: z :: t -> printfn $"{hex addr} MOD {reg x} = {reg y} m {reg z}" ; disassemble labels (addr + 4) t 109 | | 16uy :: x :: y :: z :: t -> printfn $"{hex addr} AND {reg x} = {reg y} & {reg z}" ; disassemble labels (addr + 4) t 110 | | 17uy :: x :: y :: z :: t -> printfn $"{hex addr} OR {reg x} = {reg y} | {reg z}" ; disassemble labels (addr + 4) t 111 | | 18uy :: x :: y :: z :: t -> printfn $"{hex addr} XOR {reg x} = {reg y} ^ {reg z}" ; disassemble labels (addr + 4) t 112 | | 19uy :: x :: y :: t -> printfn $"{hex addr} NOT {reg x} = ~{reg y}" ; disassemble labels (addr + 3) t 113 | | 20uy :: x :: y :: z :: t -> printfn $"{hex addr} SHL {reg x} = {reg y} << {reg z}" ; disassemble labels (addr + 4) t 114 | | 21uy :: x :: y :: z :: t -> printfn $"{hex addr} SHR {reg x} = {reg y} >> {reg z}" ; disassemble labels (addr + 4) t 115 | | 22uy :: x :: y :: z :: w :: t -> printfn $"{hex addr} BEQ {nm x y} if {reg z} = {reg w}" ; disassemble labels (addr + 5) t 116 | | 23uy :: x :: y :: z :: w :: t -> printfn $"{hex addr} BNE {nm x y} if {reg z} <> {reg w}" ; disassemble labels (addr + 5) t 117 | | 24uy :: x :: y :: z :: w :: t -> printfn $"{hex addr} BGT {nm x y} if {reg z} > {reg w}" ; disassemble labels (addr + 5) t 118 | | 25uy :: x :: y :: z :: w :: t -> printfn $"{hex addr} BGE {nm x y} if {reg z} >= {reg w}" ; disassemble labels (addr + 5) t 119 | | 26uy :: x :: y :: z :: w :: t -> printfn $"{hex addr} BLT {nm x y} if {reg z} < {reg w}" ; disassemble labels (addr + 5) t 120 | | 27uy :: x :: y :: z :: w :: t -> printfn $"{hex addr} BLE {nm x y} if {reg z} <= {reg w}" ; disassemble labels (addr + 5) t 121 | | 28uy :: x :: y :: t -> printfn $"{hex addr} JUMP {nm x y}" ; disassemble labels (addr + 3) t 122 | | 29uy :: x :: y :: t -> printfn $"{hex addr} CALL {nm x y}" ; disassemble labels (addr + 3) t 123 | | 30uy :: x :: t -> printfn $"{hex addr} EXEC pc = {reg x}" ; disassemble labels (addr + 2) t 124 | | 31uy :: t -> printfn $"{hex addr} RET" ; disassemble labels (addr + 1) t 125 | | 32uy :: x :: y :: z :: t -> printfn $"{hex addr} READ ({x},{y},{z})" ; disassemble labels (addr + 1) t 126 | | 33uy :: x :: y :: z :: t -> printfn $"{hex addr} WRITE ({x},{y},{z})" ; disassemble labels (addr + 1) t 127 | | 255uy :: x :: y :: t -> printfn $"{hex addr} ALLOT {valuexy x y}" ; disassemble labels (addr + 3 + (valuexy x y)) (List.skip (valuexy x y) t) 128 | | t -> word labels addr [] t 129 | 130 | File.ReadAllBytes("../../../block0.bin") 131 | |> List.ofArray 132 | |> disassemble known 0 133 | -------------------------------------------------------------------------------- /notes/jonesforth.md: -------------------------------------------------------------------------------- 1 | # JonesForth Notes 2 | 3 | - "LISP is the ultimate high-level language, ... But FORTH is in some ways the ultimate in low level programming." 4 | - Dictionary header: link, length (5-bits)/flags (3-bits), name (padded 32-bit words), definition 5 | - LATEST contains pointer to latest entry 6 | - Redefinition allowed (replace, in terms of old, etc.) 7 | - Direct threading (calls without CALL, addresses only) 8 | - NEXT (macro) ending primitives 9 | - EXIT ending secondaries 10 | - Indirect threading: Codeword points to "interpreter" or directly to machine code 11 | - DOCOL: store next word on return stack before entering 12 | - QUIT resets internal state and starts reading and interpreting commands (e.g. "quit" from your app) 13 | - Only /MOD is primitive (/ and MOD defined in terms) 14 | - NEGATE is the FORTH bitwise "NOT" function 15 | - EXIT pops return stack and does NEXT 16 | - LIT picks up value inline, pushes to stack and skips 17 | - Colon: Reads WORD, CREATEs header, appends DOCOL, marks HIDDEN, starts compiling [ 18 | - Semicolon: unHIDDEN, stops compiling ] 19 | - Can HIDE SOMETHING or LATEST @ HIDDEN the latest word 20 | - IMMEDIATE can be in the form : FOO IMMEDIATE ... ; or : FOO ... ; IMMEDIATE 21 | - Append code word with ' FOO , 22 | - QUIT clear return stack, and INTERPRETs forever (doesn't EXIT) 23 | - INTERPRET dictionary? Immediate? Number? Compiling? Error 24 | - Doesn't implement DOES> 25 | - Truth values are not -1 26 | - Variables and constants are DOCOL words? 27 | - Indirect threaded, but doesn't make use of indirection 28 | - Initial constants: VERSION R0 (top of return stack) DOCOL (pointer to) F_IMMED F_HIDDEN F_LENMASK (flags/masks) SYS_* (Linux syscalls) 29 | - Initial variables: STATE (compiling?) LATEST HERE S0 BASE 30 | - Initial primitives: 31 | DROP SWAP DUP OVER ROT -ROT 2DROP 2DUP 2SWAP ?DUP 1+ 1- 4+ 4- + - * 32 | /MOD = <> < > <= >= 0= 0<> 0< 0> 0<= 0>= AND OR XOR INVERT 33 | EXIT ! @ +! -! C! C@ C@C! CMOVE 34 | >R R> RSP@ RSP! RDROP DSP@ DSP! 35 | KEY EMIT WORD NUMBER FIND >CFA >DFA 36 | CREATE , [ ] : ; IMMEDIATE HIDDEN HIDE ' 37 | BRANCH 0BRANCH LITSTRING TELL 38 | QUIT INTERPRET CHAR EXECUTE SYSCALL3 SYSCALL2 SYSCALL1 SYSCALL0 39 | 40 | : / /MOD SWAP DROP ; 41 | : MOD /MOD DROP ; 42 | : '\n' 10 ; 43 | : BL 32 ; \ BL (BLank) is a standard FORTH word for space. 44 | : CR '\n' EMIT ; 45 | : SPACE BL EMIT ; 46 | : NEGATE 0 SWAP - ; 47 | : TRUE -1 ; 48 | : FALSE 0 ; 49 | : NOT 0= ; ( wrong! and not a standard word, but wrong for INVERT ) 50 | : LITERAL IMMEDIATE ' LIT , , ; 51 | : ':' [ CHAR : ] LITERAL ; 52 | : ';' [ CHAR ; ] LITERAL ; 53 | : '(' [ CHAR ( ] LITERAL ; 54 | : ')' [ CHAR ) ] LITERAL ; 55 | : '"' [ CHAR " ] LITERAL ; 56 | : 'A' [ CHAR A ] LITERAL ; 57 | : '0' [ CHAR 0 ] LITERAL ; 58 | : '-' [ CHAR - ] LITERAL ; 59 | : '.' [ CHAR . ] LITERAL ; 60 | : [COMPILE] IMMEDIATE WORD FIND >CFA , ; 61 | : RECURSE IMMEDIATE LATEST @ >CFA , ; 62 | : IF IMMEDIATE ' 0BRANCH , HERE @ 0 , ; 63 | : THEN IMMEDIATE DUP HERE @ SWAP - SWAP ! ; 64 | : ELSE IMMEDIATE ' BRANCH , HERE @ 0 , SWAP DUP HERE @ SWAP - SWAP ! ; 65 | : BEGIN IMMEDIATE HERE @ ; 66 | : UNTIL IMMEDIATE ' 0BRANCH , HERE @ - , ; 67 | : AGAIN IMMEDIATE ' BRANCH , HERE @ - , ; 68 | : WHILE IMMEDIATE ' 0BRANCH , HERE @ 0 , ; 69 | : REPEAT IMMEDIATE ' BRANCH , SWAP HERE @ - , DUP HERE @ SWAP - SWAP ! ; 70 | : UNLESS IMMEDIATE ' NOT , [COMPILE] IF ; ( not a standard word ) 71 | : ( IMMEDIATE 1 BEGIN KEY DUP '(' = IF DROP 1+ ELSE ')' = IF 1- THEN THEN DUP 0= UNTIL DROP ; 72 | : NIP SWAP DROP ; 73 | : TUCK SWAP OVER ; 74 | : PICK 1+ 4 * DSP@ + @ ; 75 | : SPACES BEGIN DUP 0> WHILE SPACE 1- REPEAT DROP ; 76 | : DECIMAL 10 BASE ! ; 77 | : HEX 16 BASE ! ; 78 | : U. BASE @ /MOD ?DUP IF RECURSE THEN DUP 10 < IF '0' ELSE 10 - 'A' THEN + EMIT ; 79 | : .S DSP@ BEGIN DUP S0 @ < WHILE DUP @ U. SPACE 4+ REPEAT DROP ; 80 | : UWIDTH BASE @ / ?DUP IF RECURSE 1+ ELSE 1 THEN ; 81 | : U.R SWAP DUP UWIDTH ROT SWAP - SPACES U. ; 82 | : .R SWAP DUP 0< IF NEGATE 1 SWAP ROT 1- ELSE 0 SWAP ROT THEN SWAP DUP UWIDTH ROT SWAP - SPACES SWAP IF '-' EMIT THEN U. ; 83 | : . 0 .R SPACE ; 84 | : U. U. SPACE ; 85 | : ? @ . ; 86 | : WITHIN -ROT OVER <= IF > IF TRUE ELSE FALSE THEN ELSE 2DROP FALSE THEN ; 87 | : DEPTH S0 @ DSP@ - 4- ; 88 | : ALIGNED 3 + 3 INVERT AND ; 89 | : ALIGN HERE @ ALIGNED HERE ! ; 90 | : C, HERE @ C! 1 HERE +! ; 91 | : S" IMMEDIATE STATE @ IF ' LITSTRING , HERE @ 0 , BEGIN KEY DUP '"' <> WHILE C, REPEAT DROP DUP HERE @ SWAP - 4- SWAP ! ALIGN ELSE HERE @ BEGIN KEY DUP '"' <> WHILE OVER C! 1+ REPEAT DROP HERE @ - HERE @ SWAP THEN ; 92 | : ." IMMEDIATE STATE @ IF [COMPILE] S" ' TELL , ELSE BEGIN KEY DUP '"' = IF DROP EXIT THEN EMIT AGAIN THEN ; 93 | : CONSTANT WORD CREATE DOCOL , ' LIT , , ' EXIT , ; 94 | : ALLOT HERE @ SWAP HERE +! ; 95 | : CELLS 4 * ; 96 | : VARIABLE 1 CELLS ALLOT WORD CREATE DOCOL , ' LIT , , ' EXIT , ; 97 | : VALUE WORD CREATE DOCOL , ' LIT , , ' EXIT , ; 98 | : TO IMMEDIATE WORD FIND >DFA 4+ STATE @ IF ' LIT , , ' ! , ELSE ! THEN ; 99 | : +TO IMMEDIATE WORD FIND >DFA 4+ STATE @ IF ' LIT , , ' +! , ELSE +! THEN ; 100 | : ID. 4+ DUP C@ F_LENMASK AND BEGIN DUP 0> WHILE SWAP 1+ DUP C@ EMIT SWAP 1- REPEAT 2DROP ; 101 | : ?HIDDEN 4+ C@ F_HIDDEN AND ; 102 | : ?IMMEDIATE 4+ C@ F_IMMED AND ; 103 | : WORDS LATEST @ BEGIN ?DUP WHILE DUP ?HIDDEN NOT IF DUP ID. SPACE THEN @ REPEAT CR ; 104 | : FORGET WORD FIND DUP @ LATEST ! HERE ! ; 105 | : DUMP BASE @ -ROT HEX BEGIN ?DUP WHILE OVER 8 U.R SPACE 2DUP 1- 15 AND 1+ BEGIN ?DUP WHILE SWAP DUP C@ 2 .R SPACE 1+ SWAP 1- REPEAT DROP 2DUP 1- 15 AND 1+ BEGIN ?DUP WHILE SWAP DUP C@ DUP 32 128 WITHIN IF EMIT ELSE DROP '.' EMIT THEN 1+ SWAP 1- REPEAT DROP CR DUP 1- 15 AND 1+ TUCK - >R + R> REPEAT DROP BASE ! ; 106 | : CASE IMMEDIATE 0 ; 107 | : OF IMMEDIATE ' OVER , ' = , [COMPILE] IF ' DROP , ; 108 | : ENDOF IMMEDIATE [COMPILE] ELSE ; 109 | : ENDCASE IMMEDIATE ' DROP , BEGIN ?DUP WHILE [COMPILE] THEN REPEAT ; 110 | : CFA> LATEST @ BEGIN ?DUP WHILE 2DUP SWAP < IF NIP EXIT THEN @ REPEAT DROP 0 ; 111 | : SEE WORD FIND HERE @ LATEST @ BEGIN 2 PICK OVER <> WHILE NIP DUP @ REPEAT DROP SWAP ':' EMIT SPACE DUP ID. SPACE DUP ?IMMEDIATE IF ." IMMEDIATE " THEN >DFA BEGIN 2DUP > WHILE DUP @ CASE ' LIT OF 4 + DUP @ . ENDOF ' LITSTRING OF [ CHAR S ] LITERAL EMIT '"' EMIT SPACE 4 + DUP @ SWAP 4 + SWAP 2DUP TELL '"' EMIT SPACE + ALIGNED 4 - ENDOF ' 0BRANCH OF ." 0BRANCH ( " 4 + DUP @ . ." ) " ENDOF ' BRANCH OF ." BRANCH ( " 4 + DUP @ . ." ) " ENDOF ' ' OF [ CHAR ' ] LITERAL EMIT SPACE 4 + DUP @ CFA> ID. SPACE ENDOF ' EXIT OF 2DUP 4 + <> IF ." EXIT " THEN ENDOF DUP CFA> ID. SPACE ENDCASE 4 + REPEAT ';' EMIT CR 2DROP ; 112 | : :NONAME 0 0 CREATE HERE @ DOCOL , ] ; 113 | : ['] IMMEDIATE ' LIT , ; 114 | : EXCEPTION-MARKER RDROP 0 ; 115 | : CATCH DSP@ 4+ >R ' EXCEPTION-MARKER 4+ >R EXECUTE ; 116 | : THROW ?DUP IF RSP@ BEGIN DUP R0 4- < WHILE DUP @ ' EXCEPTION-MARKER 4+ = IF 4+ RSP! DUP DUP DUP R> 4- SWAP OVER ! DSP! EXIT THEN 4+ REPEAT DROP CASE 0 1- OF ." ABORTED" CR ENDOF ." UNCAUGHT THROW " DUP . CR ENDCASE QUIT THEN ; 117 | : ABORT 0 1- THROW ; 118 | : PRINT-STACK-TRACE RSP@ BEGIN DUP R0 4- < WHILE DUP @ CASE ' EXCEPTION-MARKER 4+ OF ." CATCH ( DSP=" 4+ DUP @ U. ." ) " ENDOF DUP CFA> ?DUP IF 2DUP ID. [ CHAR + ] LITERAL EMIT SWAP >DFA 4+ - . THEN ENDCASE 4+ REPEAT DROP CR ; 119 | : Z" IMMEDIATE STATE @ IF ' LITSTRING , HERE @ 0 , BEGIN KEY DUP '"' <> WHILE HERE @ C! 1 HERE +! REPEAT 0 HERE @ C! 1 HERE +! DROP DUP HERE @ SWAP - 4- SWAP ! ALIGN ' DROP , ELSE HERE @ BEGIN KEY DUP '"' <> WHILE OVER C! 1+ REPEAT DROP 0 SWAP C! HERE @ THEN ; 120 | : STRLEN DUP BEGIN DUP C@ 0<> WHILE 1+ REPEAT SWAP - ; 121 | : CSTRING SWAP OVER HERE @ SWAP CMOVE HERE @ + 0 SWAP C! HERE @ ; 122 | : ARGC S0 @ @ ; 123 | : ARGV 1+ CELLS S0 @ + @ DUP STRLEN ; 124 | : ENVIRON ARGC 2 + CELLS S0 @ + ; 125 | : BYE 0 SYS_EXIT SYSCALL1 ; 126 | : GET-BRK 0 SYS_BRK SYSCALL1 ; 127 | : UNUSED GET-BRK HERE @ - 4 / ; 128 | : BRK SYS_BRK SYSCALL1 ; 129 | : MORECORE CELLS GET-BRK + BRK ; 130 | : R/O O_RDONLY ; 131 | : R/W O_RDWR ; 132 | : OPEN-FILE -ROT CSTRING SYS_OPEN SYSCALL2 DUP DUP 0< IF NEGATE ELSE DROP 0 THEN ; 133 | : CREATE-FILE O_CREAT OR O_TRUNC OR -ROT CSTRING 420 -ROT SYS_OPEN SYSCALL3 DUP DUP 0< IF NEGATE ELSE DROP 0 THEN ; 134 | : CLOSE-FILE SYS_CLOSE SYSCALL1 NEGATE ; 135 | : READ-FILE >R SWAP R> SYS_READ SYSCALL3 DUP DUP 0< IF NEGATE ELSE DROP 0 THEN ; 136 | : PERROR TELL ':' EMIT SPACE ." ERRNO=" . CR ; 137 | : ;CODE IMMEDIATE [COMPILE] NEXT ALIGN LATEST @ DUP HIDDEN DUP >DFA SWAP >CFA ! [COMPILE] [ ; 138 | : EAX IMMEDIATE 0 ; 139 | : ECX IMMEDIATE 1 ; 140 | : EDX IMMEDIATE 2 ; 141 | : EBX IMMEDIATE 3 ; 142 | : ESP IMMEDIATE 4 ; 143 | : EBP IMMEDIATE 5 ; 144 | : ESI IMMEDIATE 6 ; 145 | : EDI IMMEDIATE 7 ; 146 | : PUSH IMMEDIATE 50 + C, ; 147 | : POP IMMEDIATE 58 + C, ; 148 | : RDTSC IMMEDIATE 0F C, 31 C, ; 149 | : RDTSC RDTSC EAX PUSH EDX PUSH ;CODE 150 | : =NEXT DUP C@ AD <> IF DROP FALSE EXIT THEN 1+ DUP C@ FF <> IF DROP FALSE EXIT THEN 1+ C@ 20 <> IF FALSE EXIT THEN TRUE ; 151 | : (INLINE) @ BEGIN DUP =NEXT NOT WHILE DUP C@ C, 1+ REPEAT DROP ; 152 | : INLINE IMMEDIATE WORD FIND >CFA DUP @ DOCOL = IF ." Cannot INLINE FORTH words" CR ABORT THEN (INLINE) ; 153 | : WELCOME S" TEST-MODE" FIND NOT IF ." JONESFORTH VERSION " VERSION . CR UNUSED . ." CELLS REMAINING" CR ." OK " THEN ; 154 | -------------------------------------------------------------------------------- /hardware/register_v2/bootstrap.fs: -------------------------------------------------------------------------------- 1 | header, : ] header, ] ; 2 | 3 | : \ 10 parse 2drop ; immediate 4 | 5 | : char parse-name drop c@ ; 6 | : [char] char postpone literal ; immediate 7 | 8 | : ( [char] ) parse 2drop ; immediate 9 | 10 | ( now we can use comments like this! ) 11 | \ or like this to the end of the line! 12 | 13 | \ create ( "name" -- ) parse name, create definition, runtime ( -- a-addr ) pushes address of data field (does not allocate data space in data field). Execution semantics may be extended by does>. 14 | : create 15 | header, \ code to push dfa and return 16 | x pc cp, \ x=pc 17 | 14 y ldc, \ y=14 18 | x x y add, \ x+=y 19 | x pushd, 20 | ret, 21 | ; 22 | 23 | : >body ( xt -- a-addr ) 16 + ; 24 | 25 | : buffer: ( u "" -- ; -- addr ) create allot ; 26 | 27 | ( patch return to jump to instance code address given ) 28 | : (does) 29 | latest @ 2 + \ to length/flag 30 | dup c@ + 1+ \ to code 31 | 10 + \ to return 32 | 33 over ! \ 2100 -> ld+ zero pc pc pc=[pc] -- jump to following address TODO: assemble? 33 | 2 + ! \ to address passed to us 34 | ; 35 | 36 | \ ['] ( "name" -- ) parse and find name 37 | : ['] ' postpone literal ; immediate 38 | 39 | \ does> ( C: colon-sys1 -- colon-sys2 ) append run-time and initialization semantics below to definition. 40 | \ ( -- ) ( R: nest-sys1 -- ) Runtime: replace execution semantics 41 | \ ( i * x -- i * x a-addr ) ( R: -- nest-sys2 ) Initiation: push data field address 42 | \ ( i * x -- j * x ) Execution: execute portion of definition beginning with initiation semantics 43 | : does> 44 | here 12 + postpone literal \ compile push instance code address 45 | ['] (does) jump, 46 | ; immediate 47 | 48 | \ variable ( "name" -- ) parse name, create definition, reserve cell of data space, runtime ( -- a-addr ) push address of data space (note: uninitialized) 49 | : variable create 1 cells allot ; 50 | 51 | \ constant ( x "name" -- ) parse name, create definition to push x at runtime ( -- x ) 52 | : constant create , does> @ ; 53 | 54 | \ can redefine 55 | 32 constant bl 56 | 2 constant cell 57 | 58 | \ can redefine 59 | : cells cell * ; \ note: less efficient than 2* 60 | : cell+ cell + ; 61 | 62 | \ another create ... does> ... example 63 | : point create , , does> dup cell+ @ swap @ ; 64 | 65 | ( --- primitive control-flow ------------------------------------------------- ) 66 | 67 | : branch, ( -- dest ) 0 jump, here 2 - ; \ dummy jump, push pointer to patch 68 | : 0branch, ( -- dest ) x popd, 0 y ldv, here 2 - pc y x cp?, ; \ dummy jump if 0 to address, push pointer to patch 69 | : patch, ( orig -- ) here swap ! ; \ patch jump to continue here (note: s! -> !) 70 | 71 | \ ... if ... then 72 | \ ... if ... else ... then 73 | : if ( C: -- orig ) 0branch, ; immediate \ dummy branch on 0, push pointer to address 74 | : then ( orig -- ) patch, ; immediate \ patch if/else to continue here 75 | : else ( C: orig1 -- orig2 ) branch, swap patch, ; immediate \ patch previous branch to here, dummy unconditionally branch over false block (note: then -> patch,) 76 | 77 | : begin ( C: -- dest ) here ; immediate \ begin loop 78 | : again ( C: dest -- ) jump, ; immediate \ jump back to beginning 79 | : until ( C: dest -- ) 0branch, ! ( s! -> ! ) ; immediate \ branch on 0 to address 80 | : while ( C: dest -- orig dest ) 0branch, swap ; immediate \ continue while condition met (0= if), 81 | : repeat ( C: orig dest -- ) postpone again ( again, -> postpone again, because now immediate ) here swap ! ( s! -> ! ) ; immediate \ jump back to beginning, patch while to here 82 | 83 | : do ( limit start -- ) ( C: -- false addr ) \ begin do-loop (immediate 2>r begin false) 84 | ['] 2>r call, 85 | false \ no addresses to patch (initially) 86 | postpone begin ( begin, -> postpone begin ) ; immediate 87 | 88 | : ?do ( limit start -- ) ( C: -- false addr true addr ) 89 | ['] 2dup call, 90 | ['] 2>r call, 91 | ['] <> call, 92 | false \ terminator for patching 93 | postpone if ( if, -> postpone if ) 94 | true \ patch if to loop 95 | postpone begin ( begin, -> postpone begin ) ; immediate 96 | 97 | : leave ( C: -- addr true ) 98 | branch, 99 | -rot true -rot ; immediate \ patch to loop (swap under if address) 100 | 101 | : +loop ( n -- ) ( C: ... flag addr -- ) \ end do-loop, add n to loop counter (immediate r> + r@ over >r < if again then 2r> 2drop) 102 | ['] r> call, 103 | ['] + call, 104 | ['] r@ call, 105 | ['] over call, 106 | ['] >r call, 107 | ['] < call, 108 | postpone if ( if, -> if ) 109 | swap postpone again ( again, -> again ) 110 | postpone then ( then, -> then, ) 111 | begin while 112 | patch, 113 | repeat 114 | ['] 2r> call, 115 | ['] 2drop call, ; immediate 116 | 117 | : loop ( C: addr -- ) 118 | 1 postpone literal 119 | postpone +loop ; immediate \ end do-loop (immediate 1 +loop) 120 | 121 | : i 2r@ ( including return from here ) drop ; 122 | : j 2r> 2r@ drop -rot 2>r ; 123 | 124 | \ : str= \ non-standard gforth 125 | \ rot over <> if drop 2drop false exit then \ not equal lengths 126 | \ 0 do 127 | \ 2dup c@ swap c@ <> if 2drop false unloop exit then \ chars not equal 128 | \ char+ swap char+ 129 | \ loop 130 | \ 2drop true ; 131 | 132 | : u< 2dup xor 0< if nip else - then 0< ; 133 | : u> swap u< ; 134 | 135 | : within ( test low high -- flag ) over - -rot - u> ; 136 | 137 | : .( [char] ) parse type ; immediate 138 | 139 | : s" branch, here [char] " parse tuck here swap cmove dup allot rot patch, swap literal, literal, ; immediate 140 | 141 | \ branch, -> branch compile dummy jump 142 | \ here -> branch here 143 | \ [char] " -> branch here " 144 | \ parse -> branch here addr len 145 | \ tuck -> branch here len addr len 146 | \ here -> branch here len addr len here 147 | \ swap -> branch here len addr here len 148 | \ cmove -> branch here len copy string into compiled word 149 | \ dup -> branch here len len 150 | \ allot -> branch here len 151 | \ rot -> here len branch 152 | \ patch, -> here len patch dummy jump 153 | \ swap -> len here 154 | \ literal, -> len compile literal address 155 | \ literal, -> compile literal length 156 | 157 | : c" branch, here [char] " parse tuck dup c, here swap cmove allot swap patch, literal, ; immediate 158 | 159 | \ branch, -> branch compile dummy jump 160 | \ here -> branch here 161 | \ [char] " -> branch here " 162 | \ parse -> branch here addr len 163 | \ tuck -> branch here len addr len 164 | \ dup -> branch here len addr len len 165 | \ c, -> branch here len addr len compile string count 166 | \ here -> branch here len addr len here 167 | \ swap -> branch here len addr here len 168 | \ cmove -> branch here len copy string into compiled word 169 | \ allot -> branch here 170 | \ swap -> here branch 171 | \ patch, -> here patch dummy jump 172 | \ literal, -> compile literal address 173 | 174 | : ." postpone s" ['] type call, ; immediate 175 | 176 | : latest-cfa latest @ 2 + dup c@ 127 and + 1+ ; ( non-standard ) 177 | : recurse latest-cfa call, ; immediate 178 | : tail-recurse latest-cfa jump, ; immediate ( non-standard ) 179 | 180 | : move 0 ?do over @ over ! cell+ swap cell+ swap loop 2drop ; \ TODO: handle overlap 181 | 182 | : (abort") rot 0<> if type abort else 2drop then ; \ internal non-standard 183 | : abort" postpone s" ['] (abort") call, ; immediate 184 | 185 | \ evaluate ( i * x c-addr u -- j * x ) save the current input source specification. 186 | \ Store minus-one (-1) in SOURCE-ID if it is present. 187 | \ Make the string described by c-addr and u both the input source and input buffer, set >IN to zero, and 188 | \ interpret. When the parse area is empty, restore the prior input source specification. 189 | : evaluate 190 | source-len @ >r source-len ! 191 | source-addr @ >r source-addr ! 192 | source-id @ >r -1 source-id ! 193 | >in @ >r 0 >in ! 194 | (evaluate) 195 | 0 source-id ! 196 | r> >in ! 197 | r> source-id ! 198 | r> source-addr ! 199 | r> source-len ! 200 | ; 201 | 202 | : original< < ; \ TODO fix redefinitions 203 | : < ( y x -- b ) 204 | over 0< over 0< invert and if \ only y negative? 205 | 2drop true exit 206 | then 207 | over 0< invert over 0< and if \ only x negative? 208 | 2drop false exit 209 | then 210 | original< \ otherwise fall back to original implementation 211 | ; 212 | 213 | : original> > ; \ TODO fix redefinitions 214 | : > ( y x -- b ) 215 | over 0< over 0< invert and if \ only y negative? 216 | 2drop false exit 217 | then 218 | over 0< invert over 0< and if \ only x negative? 219 | 2drop true exit 220 | then 221 | original> \ otherwise fall back to original implementation 222 | ; 223 | 224 | : >= 2dup > -rot = or ; \ non-standard 225 | : <= 2dup < -rot = or ; \ non-standard 226 | 227 | : min ( y x -- min ) 2dup < if drop exit then nip ; 228 | : max ( y x -- max ) 2dup < if nip exit then drop ; 229 | 230 | : spaces 0 max 0 ?do space loop ; 231 | 232 | : power ( y x -- ) \ non-standard 233 | 1 -rot 234 | begin 235 | dup 0= if 2drop exit then 236 | 1- -rot swap over * swap rot 237 | again ; 238 | 239 | : write-boot-block ( -- ) 0 0 here write-block ; \ taken from assembler.fs 240 | 241 | .( writing boot block ) 242 | write-boot-block 243 | -------------------------------------------------------------------------------- /hardware/register/bootstrap.fs: -------------------------------------------------------------------------------- 1 | header, : ] header, ] ; 2 | 3 | : immediate latest @ 2 + dup @ 128 or swap ! ; 4 | 5 | : \ 10 parse 2drop ; immediate 6 | 7 | \ now we can use comments like this 8 | 9 | \ -- ASSEMBLER WORDS ----------------------------------------------------------- 10 | 11 | : pc 0 ; \ TODO 0 constant pc 12 | : zero 1 ; \ TODO 1 constant zero 13 | : one 2 ; \ TODO 2 constant one 14 | : two 3 ; \ TODO 3 constant two 15 | : four 4 ; \ TODO 4 constant four 16 | : eight 5 ; \ TODO 5 constant eight 17 | : twelve 6 ; \ TODO 6 constant twelve 18 | : fifteen 7 ; \ TODO 7 constant fifteen 19 | : #t 8 ; \ TODO 8 constant #t 20 | : #f zero ; \ TODO: zero constant #f 21 | : x 9 ; \ TODO: 9 constant x 22 | : y 10 ; \ TODO: 10 constant y 23 | : z 11 ; \ TODO: 11 constant z 24 | : w 12 ; \ TODO: 12 constant w 25 | : d 13 ; \ TODO: 13 constant d 26 | : r 14 ; \ TODO: 14 constant r 27 | 28 | : 2nybbles, 4 lshift or c, ; 29 | : 4nybbles, 2nybbles, 2nybbles, ; 30 | 31 | : halt, 0 2nybbles, ; \ ( x -- ) halt(x) (halt with exit code x) 32 | : add, 1 4nybbles, ; \ ( z y x -- ) z=y+x (addition) 33 | : sub, 2 4nybbles, ; \ ( z y x -- ) z=y-x (subtraction) 34 | : mul, 3 4nybbles, ; \ ( z y x -- ) z=y*x (multiplication) 35 | : div, 4 4nybbles, ; \ ( z y x -- ) z=y/x (division) 36 | : nand, 5 4nybbles, ; \ ( z y x -- ) z=y nand x (not-and) 37 | : shl, 6 4nybbles, ; \ ( z y x -- ) z=y<>x (bitwise shift-right) 39 | : in, 8 2nybbles, ; \ ( y x -- ) x=getc() (read from console) 40 | : out, 9 2nybbles, ; \ ( y x -- ) putc(x) (write to console) 41 | : read, 10 4nybbles, ; \ ( z y x -- ) read(z,y,x) (file z of size y -> address x) 42 | : write, 11 4nybbles, ; \ ( z y x -- ) write(z,y,x) (file z of size y <- address x) 43 | : ld16+, 12 4nybbles, ; \ ( z y x -- ) z<-[y] y+=x (load from memory and inc/dec pointer) 44 | : st16+, 13 4nybbles, ; \ ( z y x -- ) z->[y] y+=x (store to memory and inc/dec pointer) 45 | : lit8, 14 2nybbles, c, ; \ ( v x -- ) x=v (load constant signed v into x) 46 | : cp?, 15 4nybbles, ; \ ( z y x -- ) z=y if x=0 (conditional copy) 47 | 48 | : cp, zero cp?, ; \ ( y x -- ) y=x (unconditional copy) 49 | : ld16, zero ld16+, ; \ ( y x -- ) y<-[x] (load from memory) 50 | : st16, zero st16+, ; \ ( y x -- ) y->[x] (store to memory) 51 | 52 | : jump, pc pc ld16, , ; \ ( addr -- ) unconditional jump to address (following cell) 53 | : lit16, pc two ld16+, , ; \ ( val reg -- ) 54 | : not, dup nand, ; \ ( y x -- ) 55 | 56 | : pick [ x d ld16, x x four mul, x x four add, x x d add, x x ld16, x d st16, ] ; \ ( n...x -- n...x n ) copy 0-based nth stack value to top 57 | : and, 2 pick -rot nand, dup not, ; 58 | : or, dup dup not, over dup not, nand, ; \ ( z y x -- ) 59 | 60 | : push, dup dup four sub, st16, ; \ ( reg ptr -- ) 61 | : pop, four ld16+, ; \ ( reg ptr -- ) 62 | : pushd, d push, ; \ ( reg -- ) 63 | : popd, d pop, ; \ ( reg -- ) 64 | : pushr, r push, ; \ ( reg -- ) 65 | : popr, r pop, ; \ ( reg -- ) 66 | 67 | : literal, x lit16, x pushd, ; \ ( val -- ) push literal value onto stack 68 | 69 | : call, pc pushr, jump, ; \ call, ( addr -- ) 70 | : ret, x popr, x x four add, pc x cp, ; \ ret, ( -- ) 71 | 72 | : read-block [ x popd, y popd, z popd, z y x read, ] ; \ ( file addr size -- ) block file of size -> address 73 | : write-block [ x popd, y popd, z popd, z y x write, ] ; \ ( file addr size -- ) block file of size -> address 74 | 75 | \ -- ADD MISSING PRIMITIVES ---------------------------------------------------- 76 | 77 | : nand [ x popd, y popd, x y x nand, x pushd, ] ; \ ( y x -- not-and ) not and (non-standard) 78 | : invert [ x d ld16, x x not, x d st16, ] ; \ ( x -- result ) invert bits 79 | : negate [ x d ld16, x x not, x x one add, x d st16, ] ; \ ( x -- result ) arithetic inverse (invert 1+) (0 swap -) 80 | 81 | : ?dup [ x d ld16, y popr, y y four add, pc y x cp?, x pushd, pc y cp, ] ; \ ( x -- 0 | x x ) duplicate top stack value if non-zero 82 | : 2swap [ x d ld16, y d eight add, z y ld16, z d st16, x y st16, x d four add, y x ld16, z d twelve add, w z ld16, w x st16, y z st16, ] ; \ ( w z y x -- y x w z ) swap top two pairs of stack values 83 | : 0<> [ x d ld16, y #t cp, y #f x cp?, y d st16, ] ; \ ( y x -- b ) true if not equal to zero 84 | 85 | : bye [ zero halt, ] ; \ ( -- ) halt machine 86 | : (bye) [ x popd, x halt, ] ; \ ( code -- ) halt machine with return code (non-standard) 87 | : / [ x popd, y popd, x y x div, x pushd, ] ; \ ( y x -- quotient ) division 88 | : mod [ x popd, y popd, z y x div, z z x mul, z y z sub, z pushd, ] ; \ ( y x -- remainder ) remainder of division 89 | : /mod [ x popd, y popd, z y x div, w z x mul, w y w sub, w pushd, z pushd, ] ; \ ( y x -- remainder quotient ) remainder and quotient result of division 90 | 91 | : hex 16 base ! ; \ ( -- ) set number-conversion radix to 16 92 | : octal 8 base ! ; \ ( -- ) set number-conversion radix to 8 (non-standard) 93 | : binary 2 base ! ; \ ( -- ) set number-conversion radix to 2 (non-standard) 94 | 95 | : 2* [ x popd, x x one shl, x pushd, ] ; \ ( x -- result ) multiply by 2 (1 lshift) 96 | : 2/ [ x popd, y one fifteen shl, y y x and, x x one shr, x x y or, x pushd, ] ; \ ( x -- result ) divide by 2 (1 rshift) 97 | 98 | : depth [ 8 x lit8, x x d sub, x x four div, x pushd, ] ; \ ( -- depth ) data stack depth \ TODO: why 8? 99 | 100 | : abort [ (clear-data) quit ] ; 101 | 102 | \ -- PRIMITIVE CONTROL FLOW ---------------------------------------------------- 103 | 104 | : 0branch, x popd, 0 y lit16, here 2 - pc y x cp?, ; \ ( -- dest ) dummy jump if 0 to address, push pointer to patch 105 | : branch, 0 jump, here 2 - ; \ ( -- dest ) 106 | : patch, here swap ! ; \ ( orig -- ) 107 | 108 | \ ... if ... then | ... if ... else ... then 109 | : if 0branch, ; immediate \ ( C: -- orig ) dummy branch on 0, push pointer to address 110 | : then patch, ; immediate \ ( orig -- ) patch if/else to continue here 111 | : else branch, swap patch, ; immediate \ ( C: orig1 -- orig2 ) patch previous branch to here, dummy unconditionally branch over false block 112 | 113 | \ \ begin ... again | begin ... until | begin ... while ... repeat (note: not begin ... while ... again!) 114 | : begin here ; immediate \ ( C: -- dest ) begin loop 115 | : again jump, ; immediate \ ( C: dest -- ) jump back to beginning 116 | : until 0branch, ! ; immediate \ ( C: dest -- ) branch on 0 to address \ NEW: not in kernel; 117 | : while 0branch, swap ; immediate \ ( C: dest -- orig dest ) continue while condition met (0= if), 118 | : repeat jump, here swap ! ; immediate \ ( C: orig dest -- ) jump back to beginning, patch while to here 119 | 120 | \ -- CONTINUE BOOTSTRAPPING ---------------------------------------------------- 121 | 122 | \ these are no-ops on RM16, but are standard and should be used for portability 123 | : align ; \ ( -- ) reserve space to align data space pointer (no-op on RM16) 124 | : aligned ; \ ( addr -- addr ) align address (no-op on RM16) 125 | : chars ; \ ( x -- n-chars ) size in address units of n-chars (no-op) 126 | 127 | : char+ 1+ ; \ ( addr -- addr ) add size of char to address (1+) 128 | : cells 2* ; \ ( x -- n-cells ) size in address units of n-cells (2*) 129 | : cell+ 2 + ; \ ( addr -- addr ) add size of cell to address (2 +) 130 | 131 | : 2! tuck ! cell+ ! ; \ ( y x addr -- ) store x y at consecutive addresses (tuck ! cell+ !) 132 | : 2@ dup cell+ @ swap @ ; \ ( addr -- y x ) fetch pair of consecutive addresses (dup cell+ @ swap @) 133 | 134 | : xor 2dup or -rot and invert and ; \ ( y x -- result ) logical/bitwise exclusive or (2dup or -rot and invert and) 135 | : abs dup 0< if negate then ; \ ( x -- |x| ) absolute value (dup 0< if negate then) 136 | : j 2r> 2r@ drop -rot 2>r ; \ ( -- x ) ( R: x -- x ) copy next outer loop index (2r> 2r@ drop -rot 2>r) (x r twelve add, x x ld16, x pushd, ret,) 137 | 138 | : postpone parse-name >counted find 1 = if call, then ; immediate \ only works for immediate words -- TODO: error for not found or non-immediate 139 | 140 | : char parse-name drop c@ ; 141 | : [char] char postpone literal, ; immediate 142 | 143 | : ( [char] ) parse 2drop ; immediate 144 | 145 | ( now comments like this work too ) 146 | 147 | \ create ( "name" -- ) parse name, create definition, runtime ( -- a-addr ) pushes address of data field (does not allocate data space in data field). Execution semantics may be extended by does>. 148 | : create 149 | header, \ code to push dfa and return 150 | x pc cp, \ x=pc 151 | 14 y lit8, \ y=14 152 | x x y add, \ x+=y 153 | x pushd, 154 | ret, 155 | ; 156 | 157 | : >body 16 + ; ( xt -- a-addr ) 158 | 159 | : buffer: create allot ; ( u "" -- ; -- addr ) 160 | 161 | ( patch return to jump to instance code address given ) 162 | : (does) 163 | latest @ 2 + \ to length/flag 164 | dup c@ + 1+ \ to code 165 | 10 + \ to return 166 | 33 over ! \ 2100 -> ld16+ zero pc pc pc=[pc] -- jump to following address TODO: assemble? 167 | 2 + ! \ to address passed to us 168 | ; 169 | 170 | \ ['] ( "name" -- ) parse and find name 171 | : ['] ' postpone literal ; immediate 172 | 173 | \ does> ( C: colon-sys1 -- colon-sys2 ) append run-time and initialization semantics below to definition. 174 | \ ( -- ) ( R: nest-sys1 -- ) Runtime: replace execution semantics 175 | \ ( i * x -- i * x a-addr ) ( R: -- nest-sys2 ) Initiation: push data field address 176 | \ ( i * x -- j * x ) Execution: execute portion of definition beginning with initiation semantics 177 | : does> 178 | here 12 + postpone literal \ compile push instance code address 179 | ['] (does) jump, 180 | ; immediate 181 | 182 | \ variable ( "name" -- ) parse name, create definition, reserve cell of data space, runtime ( -- a-addr ) push address of data space (note: uninitialized) 183 | : variable create 1 cells allot ; 184 | 185 | \ constant ( x "name" -- ) parse name, create definition to push x at runtime ( -- x ) 186 | : constant create , does> @ ; 187 | 188 | \ TODO 32 constant bl \ ( -- c ) space character value (32 constant bl) 189 | : bl 32 ; 190 | 191 | : space bl emit ; \ ( -- ) emit space character (bl emit) 192 | : word dup (skip) parse >counted ; \ ( char "ccc" -- c-addr ) skip leading delimeters, parse ccc delimited by char, return transient counted string 193 | : ' bl word find 0= if drop 0 then ; \ ( "name" -- xt ) skip leading space, parse and find name 194 | 195 | \ -- SECONDARY CONTROL FLOW ---------------------------------------------------- 196 | 197 | \ do ... loop 198 | \ do ... +loop 199 | \ do ... unloop exit ... loop 200 | \ do ... if ... leave then ... loop 201 | : do \ ( limit start -- ) ( C: -- false addr ) \ begin do-loop (immediate 2>r begin false) 202 | ['] 2>r call, 203 | false \ no addresses to patch (initially) 204 | begin ; immediate 205 | 206 | : ?do \ ( limit start -- ) ( C: -- false addr true addr ) 207 | ['] 2dup call, 208 | ['] <> call, 209 | false \ terminator for patching 210 | if 211 | true \ patch if to loop 212 | ['] 2>r call, 213 | begin ; immediate 214 | 215 | : leave \ ( C: -- addr true ) 216 | branch, 217 | -rot true -rot ; immediate \ patch to loop (swap under if address) 218 | 219 | : loop, \ ( C: addr -- ) 220 | 1 literal, 221 | ['] r> call, 222 | ['] + call, 223 | ['] r@ call, 224 | ['] over call, 225 | ['] >r call, 226 | ['] < call, 227 | [ if swap again then ] 228 | \ if, 229 | \ swap again, 230 | \ then, 231 | begin while 232 | patch, 233 | repeat 234 | ['] 2r> call, 235 | ['] 2drop call, ; immediate 236 | 237 | \ -- FORMATTED NUMBERS --------------------------------------------------------- 238 | 239 | variable np \ ( -- addr ) return address of pictured numeric output pointer (non-standard) 240 | 241 | : <# pad 64 + np ! ; \ <# ( -- ) initialize pictured numeric output (pad 64 + np !) 242 | : hold np -1 over +! @ c! ; \ ( char -- ) add char to beginning of pictured numeric output (np -1 over +! c!) 243 | : # swap base @ 2dup mod 48 + hold / swap ; \ ( ud -- ud ) prepend least significant digit to pictured numeric output, return ud/base \ TODO: doesn't work with negative values! 244 | : #s swap begin swap # swap dup 0<> while repeat swap ; \ ( ud -- ud ) convert all digits using # (appends at least 0) \ TODO: support double numbers 245 | : sign 0< if 45 hold then ; \ ( n -- ) if negative, prepend '-' to pictured numeric output 246 | : #> 2drop np @ pad 64 + over - ; \ ( xd -- addr len ) make pictured numeric output string available (np @ pad 64 + over -) 247 | : holds begin dup while 1- 2dup + c@ hold repeat 2drop ; \ ( addr len -- ) add string to beginning of pictured numeric output (begin dup while 1- 2dup + c@ hold repeat 2drop) 248 | : s>d dup 0< ; \ ( n -- d ) convert number to double-cell 249 | : . dup abs s>d <# #s rot sign #> space type ; \ ( n -- ) display value in free field format (dup abs s>d <# #s rot sign #> type space) 250 | : d. <# #s #> space type ; \ ( u -- ) display unsigned value in free field format (from double word set) 251 | : u. 0 d. ; \ ( u -- ) display unsigned value in free field format (0 <# #s #> type space) 252 | \ TODO: do/loop : .s depth dup 0 do dup i - pick . loop drop ; \ ( -- ) display values on the stack non-destructively (depth dup 0 do dup i - pick . loop drop) \ TODO: ?do bug 253 | 254 | : ? @ . ; \ ( addr -- ) display value stored at address (@ .) 255 | : unused 65535 here - ; \ ( -- remaining ) dictionary space remaining \ TODO: consider stack space? 256 | 257 | here . 258 | -------------------------------------------------------------------------------- /hardware/register_v1/readme.md: -------------------------------------------------------------------------------- 1 | # Register Machine v2 2 | 3 | Virtual "hardware" target machine (VM in C). 4 | Build with [`./machine.sh](./machine.sh). 5 | 6 | ## Instruction Set 7 | 8 | It is a register-based machine with 16 register cells and 32K cells of memory, each 16-bit. 9 | The 16 instructions are followed by one to three nybble operands - register indices, memory addresses, ... 10 | 11 | | Mnumonic | Op Code | | | | Effect | Description | 12 | | -------- | ------- | --- | --- | --- | ---------------- | ---------------------------- | 13 | | halt | 0 | x | | | | Halt machine with code x | 14 | | ldc | 1 | x | y | z | x = yz | Load constant value (signed) | 15 | | ld+ | 2 | x | y | z | z = [y] y += x | Load from memory | 16 | | st+ | 3 | x | y | z | [z] = y z += x | Store to memory | 17 | | cp? | 4 | x | y | z | z = y if x | Conditional copy registers | 18 | | add | 5 | x | y | z | z = y + x | Addition | 19 | | sub | 6 | x | y | z | z = y - x | Subtraction | 20 | | mul | 7 | x | y | z | z = y × x | Multiplication | 21 | | div | 8 | x | y | z | z = y ÷ x | Division | 22 | | nand | 9 | x | y | z | z = y nand x | Nand | 23 | | shl | 10 | x | y | z | z = y << x | Bitwise shift-left | 24 | | shr | 11 | x | y | z | z = y >> x | Bitwise shift-right | 25 | | in | 12 | x | | | x = getc() | Read from console | 26 | | out | 13 | x | | | putc(x) | Write to console | 27 | | read | 14 | x | y | z | | File (z) of (y) -> core (x) | 28 | | write | 15 | x | y | z | | File (z) of (y) <- core (x) | 29 | 30 | The machine loads an `block0.bin` of little-endian encoded memory cells at startup and begins executing at address zero. 31 | 32 | ## Demo 33 | 34 | A demo `block0.bin` may be built (see Assembler section below) which will simply capitalize console input by subtracting 32 from input characters: 35 | 36 | | Assembly | Op | | | | Encoded | 37 | | ----------------- | ----- | ------ | ---- | ---- | ------------------- | 38 | | `2 constant two` | | | | | (compile time asm) | 39 | | `12 constant one` | | | | | (compile time) | 40 | | `13 constant x` | | | | | (compile time) | 41 | | `14 constant y` | | | | | (compile time) | 42 | | `15 constant z` | | | | | (compile time) | 43 | | `2 two ldc,` | `ldc` | `two` | 0 | 2 | 12 02 (assembler) | 44 | | `1 one ldc,` | `ldc` | `one` | 0 | 1 | 1C 01 | 45 | | `32 y ldc, ` | `ldc` | `y` | 2 | 0 | 1E 20 | 46 | | `label 'loop` | | | | | (compile time) | 47 | | `x in,` | `in` | `x` | | | CD | 48 | | `z x one add,` | `add` | `one` | `x` | `z` | 5CDF | 49 | | `'loop z jmz,` | `ld+` | `two` | `pc` | `t` | 2203 0600 ('loop) | 50 | | | `cp?` | `z` | `t` | `pc` | 4F30 | 51 | | `x x y sub,` | `sub` | `y` | `x` | `x` | 6EDD | 52 | | `x out` | `out` | `x` | | | DD | 53 | | `'loop jump,` | `ld+` | `zero` | `pc` | `pc` | 2100 0600 ('loop) | 54 | 55 | The full `block0.bin` contains the following 22 bytes: `1202 1C01 1E20 CD 5CDF 2203 0600 4F30 6EDD DD 2100 0600`. 56 | 57 | After assembling a `block0.bin` (see Assembler section below), we may run the machine and type something (e.g. `hello`): 58 | 59 | $ ./machine 60 | hello 61 | HELLO 62 | 63 | ## Machine Walkthrough 64 | 65 | This is a register-based machines, like many popular architectures today (e.g. Intel, AMD, ARM, ...). 66 | 67 | ```c 68 | short reg[16] = {}; 69 | unsigned char mem[0x8000]; 70 | ``` 71 | 72 | We have 16 registers, 32K cells of memory. The zeroth register is the program counter (`pc`) pointing to instructions to be executed. 73 | 74 | ```c 75 | readBlock(0, SHRT_MAX, 0); 76 | ``` 77 | 78 | When the machine boots an image file populates memory. 79 | 80 | ```c 81 | unsigned char c = NEXT; 82 | unsigned char j = NEXT; 83 | unsigned char i = HIGH(c); 84 | unsigned char x = LOW(c); 85 | unsigned char y = HIGH(j); 86 | unsigned char z = LOW(j); 87 | ``` 88 | 89 | The instructions reference register numbers. For example `add` needs to know which two registers to sum and the register in which to deposit the result. We'll refer to these as `x`, `y` and `z`. The macros are shorthand for fetching the `NEXT` slot in the instruction stream and getting the `HIGH()` or `LOW()` nybble. The `x`, `y` or `y` register numbers are used. 90 | 91 | ```c 92 | switch(i) 93 | { 94 | case 0: // ... 95 | case 1: // ... 96 | case 2: // ... 97 | // ... 98 | } 99 | } 100 | ``` 101 | 102 | The main loop merely fetches and processes instructions one-by-one. 103 | 104 | 105 | ```c 106 | switch(i) 107 | { 108 | case 0: // HALT 109 | return reg[x]; 110 | // ... 111 | } 112 | ``` 113 | 114 | The first instruction is a simple halt (the default when encountering zeroed memory). 115 | 116 | ```c 117 | switch(i) 118 | { 119 | // ... 120 | case 1: // LDC 121 | reg[x] = (signed char)((y << 4) | z); 122 | break; 123 | case 2: // LD+ 124 | reg[z] = (mem[reg[y]] | (mem[reg[y] + 1] << 8)); 125 | reg[y] += reg[x]; 126 | break; 127 | case 3: // ST+ 128 | mem[reg[z]] = reg[y]; // truncated to byte 129 | mem[reg[z] + 1] = (reg[y] >> 8); // truncated to byte 130 | reg[z] += reg[x]; 131 | break; 132 | case 4: // CP? 133 | if (reg[x] == 0) reg[z] = reg[y]; 134 | break; 135 | // ... 136 | } 137 | ``` 138 | 139 | The next several instructions move data around. Instruction `1` loads a constant (`ldc`) from the following byte in the instruction stream into a register. The next two instructions (`2` and `3`) load (`ld+`) from and store (`st+`) to memory by an address taken from the instruction stream and then add a value to the register used as an index. Instruction `4` conditionally copies (`cp?`) one register into another depending on the value of a third register. 140 | 141 | Note that there is no jump instruction, but we can build this by copying into the zeroth (program counter) register. And we can use the conditional copy instruction to build various conditional branching instructions. We also don't have a call instruction, but can build our own return address stack and make add this ourselves! 142 | 143 | ```c 144 | switch(i) 145 | { 146 | // ... 147 | case 5: // ADD 148 | reg[z] = reg[y] + reg[x]; 149 | break; 150 | case 6: // SUB 151 | reg[z] = reg[y] - reg[x]; 152 | break; 153 | case 7: // MUL 154 | reg[z] = reg[y] * reg[x]; 155 | break; 156 | case 8: // DIV 157 | reg[z] = reg[y] / reg[x]; 158 | break; 159 | // ... 160 | } 161 | ``` 162 | 163 | We have basic arithmetic operations, just as in the Python interpreter. Technically, we could have built subtraction, multiplication and division from just `add` and `shl` (below), which would be a fun exercise, but we have room to include them here for convenience. 164 | 165 | ```c 166 | switch(i) 167 | { 168 | // ... 169 | case 9: // NAND 170 | reg[z] = ~(reg[y] & reg[x]); 171 | break; 172 | case 10: // SHL 173 | reg[z] = reg[y] << reg[x]; 174 | break; 175 | case 11: // SHR 176 | reg[z] = reg[y] >> reg[x]; 177 | break; 178 | // ... 179 | } 180 | ``` 181 | 182 | The only bit twiddling instructions are `nand`, from which we can build the others (`and`, `or`, `xor`, `not`, ...) and shift left (`shl`) and right (`shr`). Again, some of the bitwise operators can be thought of as logical operators if we use `-1` (all bit set) to represent true and `0` to represent false. Also, `shl` can be thought of as multiplication by 2 and `shr` as division by 2. In fact, some Forths call these `2*` and `2/`. Note that these work on 16-bit signed `short` values and not floating point as in the Python interpreter, which will pose an interesting problem when we port turtle graphics. 183 | 184 | ```c 185 | switch(i) 186 | { 187 | // ... 188 | case 12: // IN 189 | reg[0]--; 190 | reg[x] = getc(stdin); 191 | if (feof(stdin)) { clearerr(stdin); } 192 | break; 193 | case 13: // OUT 194 | reg[0]--; 195 | wprintf(L"%lc", reg[x]); 196 | fflush(stdout); 197 | break; 198 | // ... 199 | } 200 | ``` 201 | 202 | Standard I/O is supported by `in` and `out` instructions. We use `wprintf(...)` rather than `putc(...)` in order to support emitting Unicode characters. 203 | 204 | 205 | ```c 206 | switch(i) 207 | { 208 | // ... 209 | case 14: // READ 210 | readBlock(reg[z], reg[y], reg[x]); 211 | break; 212 | case 15: // WRITE 213 | writeBlock(reg[z], reg[y], reg[x]); 214 | break; 215 | default: 216 | printf("Invalid instruction! (%i)\n", i); 217 | return 1; 218 | } 219 | ``` 220 | 221 | The `read` and `write` instructions allow loading and saving block files and will facilitate using this machine to build boot images. 222 | 223 | ## Assembler 224 | 225 | A [Forth-based assembler is provided](./assembler.f), allowing the above program [to be expressed](./test.f) as: 226 | 227 | ```forth 228 | 12 constant one 229 | 13 constant x 230 | 14 constant y 231 | 15 constant z 232 | 233 | 1 one ldc, 234 | 32 y ldc, 235 | 236 | label 'loop 237 | x in, 238 | z x one add, 239 | 'loop z jmz, 240 | x x y sub, 241 | x out, 242 | 'loop jump, 243 | 244 | assemble 245 | ``` 246 | 247 | This is a pretty nice assembly format, leaving all the power of Forth available as a "macro assembler." 248 | 249 | A new `block0.bin` may be build with [`./test.sh`](./test.sh). 250 | 251 | In addition to the `label` mechanism to give names to addresses for backward jumps (most common), there are `ahead,` and `continue,` words to skip over code (likely for library routines). 252 | 253 | ### Assembler Walkthrough 254 | 255 | TODO 256 | 257 | Building an assembler in Forth is surprisingly easy. 258 | 259 | ```forth 260 | variable h 261 | : here h @ ; 262 | : , here ! here 2 + h ! ; 263 | : c, here c! here 1 + h ! ; 264 | ``` 265 | 266 | We start with a _dictionary pointer_ (`h`, which we'll soon use to pack a dictionary structure). The `here` word merely fetches the pointer. The comma (`,`) word appends a 16-bit value to the dictionary space and increments the pointer, while c-comma (`c,`) appends a single byte. 267 | 268 | ```forth 269 | : 2nyb, 4 << or c, ; 270 | : 4nyb, 2nyb, 2nyb, ; 271 | ``` 272 | 273 | A couple of helpers are used to pack nybbles. 274 | 275 | With just these, we can build words taking instruction operands from the stack and packing into the dictionary. 276 | 277 | ```forth 278 | : halt, 0 2nyb, ; 279 | : ldc, 1 2nyb, c, ; 280 | : ld+, 2 4nyb, ; 281 | : st+, 3 4nyb, ; 282 | : cp?, 4 4nyb, ; 283 | : add, 5 4nyb, ; 284 | : sub, 6 4nyb, ; 285 | : mul, 7 4nyb, ; 286 | : div, 8 4nyb, ; 287 | : nand, 9 4nyb, ; 288 | : shl, 10 4nyb, ; 289 | : shr, 11 4nyb, ; 290 | : in, 12 2nyb, ; 291 | : out, 13 2nyb, ; 292 | : read, 14 4nyb, ; 293 | : write, 15 4nyb, ; 294 | ``` 295 | 296 | Because the assembler is hosted in Forth, we have all the power of Forth to automate and make helper words for anything we like; make this a _macro assembler_. 297 | 298 | ```forth 299 | : label here constant ; 300 | : assemble 0 here 0 write halt ; 301 | ``` 302 | 303 | For now, we've added `label` word that creates a constant giving a name to the current address (`here`). This is used, for example, in the test assembly above where we `label 'start` at the beginning of a loop and later `'start jump,`. The `assemble` word writes memory to an image file (and displays the current size of the dictionary). 304 | 305 | TODO: talk about the predefined constants and pseudo instructions 306 | 307 | ```forth 308 | : ahead, here 2 + 0 zero jmz, ; ( dummy jump, push address ) 309 | : continue, here swap ! ; ( patch jump ) 310 | ``` 311 | 312 | The `label` mechanism works for backward jumps, which may be most common. The `ahead,` and `continue,` words allow us to skip over code. A little tricky, but `ahead,` packs a `jump,` with a dummy (`0`) value and pushes the address of the jump value (`here 1 +`). The `continue,` word is used wherever we want to jump _to_. It patches the jump value to do here (`here swap !`; storing the current `here` at the previously pushed address). 313 | 314 | ## Interpreter 315 | 316 | TODO 317 | 318 | ### Inner Interpreter Walkthrough 319 | 320 | TODO --------------------------------------------------------------------------------