├── .gitattributes ├── .gitignore ├── LICENSE ├── Makefile ├── cal ├── dump ├── examples ├── 3_node_ram.aforth ├── counter.aforth ├── crystal.aforth ├── fast-ram-node.aforth ├── flash-sim.el ├── flash.el ├── hmm-sim.aforth ├── lucas-series.aforth ├── node600-async.aforth ├── node709VCOM.aforth ├── port-execution.aforth ├── probe-demo.el ├── reset-target-chip.aforth ├── sensortag-listen.py ├── sensortag.aforth ├── sram-demo.aforth ├── stack.aforth ├── test-print.aforth ├── test-print.el ├── test-print2.aforth ├── variables.aforth ├── vm.aforth └── watch-crystal-counter-test.aforth ├── ga ├── ga-load ├── ga-sim ├── lib ├── 600serial.aforth ├── 708serial.aforth ├── 715crystal.aforth ├── __test.aforth ├── sram-minimal-master.aforth └── sram.aforth ├── make-ga-script.sh ├── raw-rom-dump.txt ├── readme.org ├── ref ├── OkadBack.cf ├── OkadBack.txt ├── cf2f.py ├── cfword.py ├── f18-compiler.html ├── rom.html ├── spi-flash.txt └── sram.html ├── src ├── aforth-compile.el ├── aforth-mode.el ├── aforth-parse.el ├── arg-parser.el ├── assemble.rkt ├── bootstream.rkt ├── common.rkt ├── compare.sh ├── compile.rkt ├── convert.rkt ├── disassemble.rkt ├── dump-rom.py ├── el.rkt ├── f18a.rkt ├── ga-compile-print.rkt ├── ga-loadup.el ├── ga-main.el ├── ga-run-simulator.el ├── ga-serial.el ├── ga.rkt ├── ga144-map.el ├── ga144-sim.el ├── ga144.rkt ├── interpreter.rkt ├── listen.py ├── read.rkt ├── rkt.el ├── rom-dump-bootstream.rkt ├── rom-dump.rkt ├── rom.rkt ├── sd.el └── stack.rkt ├── tests ├── ga-benchmark.el ├── ga-test-pins.el ├── ga-test-target-chip.el ├── ga-tests.el ├── test-breakpoints.rkt ├── test-compiler.rkt ├── test-hmm.rkt ├── test-target-chip.rkt ├── test-word-hook.rkt └── tests.rkt └── variables.aforth /.gitattributes: -------------------------------------------------------------------------------- 1 | *.aforth linguist-language=Forth 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | ga 2 | ga-sim 3 | test-out/ 4 | 5 | compiled/ 6 | TAGS 7 | _[^_]* 8 | *.elc 9 | *.pyc 10 | *~ 11 | 12 | .emacs.desktop 13 | .emacs.desktop.lock 14 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | lisp: ga 2 | rm -f src/*.elc 3 | ./ga --byte-compile 4 | 5 | ga: 6 | ./make-ga-script.sh 7 | 8 | install: 9 | cp -f ga /usr/bin/ga 10 | cp -f ga-load /usr/bin/ga-load 11 | cp -f ga-sim /usr/bin/ga-sim 12 | 13 | uninstall: 14 | rm /usr/bin/ga 15 | rm /usr/bin/ga-load 16 | rm /usr/bin/ga-sim 17 | 18 | .PHONY: clean check init install lisp ga 19 | 20 | clean: 21 | rm -rf compiled/ 22 | rm -rf test-out 23 | find . -type f -name "*.elc" -exec rm {} \; 24 | 25 | check: 26 | racket tests/test-compiler.rkt 27 | racket tests/tests.rkt 28 | -------------------------------------------------------------------------------- /cal: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python 2 | 3 | # Compile And Load a program into a GA144 and listen for output 4 | 5 | # This script was originally based on work by James Bowman 6 | # https://github.com/jamesbowman 7 | # 8 | 9 | from sys import argv 10 | import subprocess 11 | from subprocess import call 12 | from serial import Serial 13 | import time 14 | from struct import unpack 15 | 16 | def write(bs, serial): 17 | # reboot by dropping RTS 18 | if target: 19 | target.setRTS(0) 20 | target.setRTS(1) 21 | serial.setRTS(0) 22 | serial.setRTS(1) 23 | serial.write(bs) 24 | serial.flush() 25 | 26 | #18bit words transmitted using 4 bytes with format: 27 | # upper2 middle8 lower8 wordcode 28 | # 29 | # wordcodes: 30 | # 0: receive 18 bit word 31 | # 1: exit 32 | def listen(port, speed, serial, verbose=True): 33 | if verbose: 34 | print "Listening. port={}, speed={}".format(port, speed) 35 | 36 | def read_n( n ): 37 | x = [ord(serial.read( 1 )) for _ in range( n ) ] 38 | x.reverse() 39 | word = 0 40 | for byte in x: 41 | word = ( word << 8 ) | byte 42 | n -= 1 43 | return word 44 | 45 | while True: 46 | n = read_n( 1 ) 47 | if n == 1: 48 | print "[exit]" 49 | return 50 | if n == 0: 51 | n = read_n( 3 ) 52 | print n & 0x3ffff 53 | else: 54 | print "ERROR -- unknown code:", s 55 | 56 | 57 | def run_command(cmd): 58 | p = subprocess.Popen(cmd, stdout=subprocess.PIPE, shell=True) 59 | x = p.communicate()[0] 60 | #print x 61 | return eval(x) 62 | 63 | default_speed = 460800 64 | default_bootstream = 'async' 65 | 66 | bootstream_types = [ "async", "2wire", "async-target" ] 67 | 68 | def print_usage_and_exist(): 69 | print "usage: ./cal filename port [--speed (default: {})] [--bootstream (default: {})] [--no-listen]".format(default_speed, default_bootstream) 70 | exit(1) 71 | 72 | if __name__ == "__main__": 73 | 74 | #speed = 921600 75 | if len(argv) not in [3, 4, 5, 7]: 76 | print_usage_and_exist() 77 | 78 | filename = argv[1] 79 | port = argv[2] 80 | 81 | speed = default_speed 82 | bootstream = default_bootstream 83 | 84 | 85 | argv = argv[3:] 86 | serial_listen = True 87 | if "--no-listen" in argv: 88 | arg.remove("--no-listen") 89 | serial_listen = False 90 | if not (len(argv) % 2 == 0): 91 | print_usage_and_exist() 92 | 93 | while argv: 94 | arg = argv.pop(0) 95 | if arg == "--speed" or arg == "-s": 96 | speed = int(argv.pop(0)) 97 | elif arg == "--bootstream" or arg == "-b": 98 | bootstream_type = argv.pop(0) 99 | if bootstream_type not in bootstream_types: 100 | print "invalid bootstream type:", bootstream_type 101 | exit(1) 102 | else: 103 | print "invalid option: ", arg 104 | 105 | cmd = "racket dump --bootstream {} {}".format(bootstream_type, filename) 106 | compiled = run_command(cmd) 107 | bootstream = compiled['bootstream'] 108 | print "Writing bootstream ({} bytes)...".format(len(bootstream)) 109 | host = Serial(port, speed) 110 | host.reset_input_buffer() 111 | 112 | # target chip serial for resetting 113 | target = None #Serial("/dev/ttyUSB4", 921600) 114 | write("".join(map(chr, bootstream)), host) 115 | 116 | if serial_listen: 117 | listen(port, speed, host) 118 | host.close() 119 | 120 | 121 | # ./cal test.aforth /dev/ttyUSB3 --speed 460800 --bootstream async-target 122 | -------------------------------------------------------------------------------- /dump: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env racket 2 | ;; -*- scheme -*- 3 | #lang racket 4 | 5 | (require "src/ga-compile-print.rkt" 6 | "src/el.rkt") 7 | 8 | (define bootstream-type (make-parameter false)) 9 | (define symbols? (make-parameter false)) 10 | (define pretty? (make-parameter false)) 11 | (define count? (make-parameter false)) 12 | (define hex? (make-parameter false)) 13 | 14 | (define input-file 15 | (command-line 16 | #:once-each 17 | [("-b" "--bootstream") bs "bootstream type" 18 | (bootstream-type bs)] 19 | [("-s" "--symbols") "include symboltable" 20 | (symbols? t)] 21 | [("-p" "--pretty") "print in human readable" 22 | (pretty? t)] 23 | [("-c" "--count") "count ram usage" 24 | (count? t)] 25 | [("-x" "--hex") "print numbers in hexadecimal format" 26 | (hex? t)] 27 | #:args (filename) 28 | filename)) 29 | 30 | (if (count?) 31 | (print-count input-file) 32 | (if (pretty?) 33 | (print-pretty input-file hex?) 34 | (print-json input-file bootstream-type symbols?))) 35 | -------------------------------------------------------------------------------- /examples/3_node_ram.aforth: -------------------------------------------------------------------------------- 1 | ( pulled from: https://github.com/jamesbowman/ga144tools/blob/master/src/nt.ga 2 | 3 | node 505 4 | /p east 5 | 6 | node 507 7 | /p west 8 | 9 | node 406 10 | /p north 11 | 12 | 13 | node 506 14 | /b north /p north 15 | 16 | : addr \ ( -- o ) 17 | \ fetch byte address 0-383 18 | \ set A to bank 19 | \ o to offset 0-63 20 | dup 2/ 2/ 2/ 2/ 2/ 2/ 21 | .. tab 22 | , 0x175 \ west 23 | , 0x115 \ south 24 | , 0x1D5 \ east 25 | 26 | : tab 27 | pop + a! @ a! 63 and ; 28 | : read 29 | @b addr 30 | .. @p ! ! 31 | .. @p a! @ !p 32 | .. @ !b ; 33 | 34 | : write 35 | @b addr 36 | .. @p ! ! @p 37 | .. @p a! . . 38 | .. @p ! . . 39 | ! @b ! ; 40 | 41 | : read_byte 42 | @b dup dup addr 43 | .. @p ! ! 44 | .. @p a! @ !p 45 | .. 2/ 2* or \ low bit of addr 46 | 2* 2* 2* \ 0 or 8 47 | push @ hibyte 48 | : lo8 49 | 255 and !b ; 50 | 51 | : hibyte 52 | 2/ unext lo8 ; 53 | 54 | : write_byte 55 | @b dup 56 | addr 57 | .. @p ! ! 58 | .. @p a! . . 59 | .. ! @b ! ; 60 | 61 | : erase 62 | @b push @b 63 | begin 64 | dup addr 65 | .. @p ! ! @p 66 | .. @p a! dup 67 | .. or ! 68 | .. ! 1 . + 69 | next ; 70 | 71 | node 606 ( test node 72 | /a south 73 | : write ( v a - ) 74 | .. @p ! 75 | .. write@506 76 | ! ! ; 77 | 78 | : read ( a - v ) 79 | .. @p ! 80 | .. read@506 81 | ! @ ; 82 | 83 | : erase ( a n - ) 84 | ( . !!break 85 | .. @p ! 86 | .. erase@506 87 | ! ! ; 88 | 89 | : main 90 | \ 111 0 write 91 | \ 222 1 write 92 | 93 | 191 for 94 | pop dup push dup write 95 | next 96 | 60 20 erase 97 | 98 | 10 read 99 | . !!printT 100 | 101 | 102 | warm ; 103 | 104 | node 705 105 | : main 106 | warm 107 | -------------------------------------------------------------------------------- /examples/counter.aforth: -------------------------------------------------------------------------------- 1 | ( ./cal counter.aforth /dev/ttyUSB3 460800 ) 2 | 3 | ( uses a crystal to maintain time.) 4 | ( sends the counter value over serial once per second ) 5 | 6 | ( the first values printed are debug values ) 7 | ( then the period delay values used for pumping the crystal is printed) 8 | ( then the second counter is printed when it is incremented ) 9 | 10 | ( uses the code from crystal.aforth and serial-out.aforth ) 11 | 12 | node 715 13 | : -osc over ! 14 | io b! for 15 | 0x30000 !b dup .. 2/ dup for unext 16 | 0x20000 !b .. over 1 and .. + for unext next 17 | dup or !b dup 30000 for 18 | drop @b - -while next ; 19 | then dup or pop drop ; 20 | : clang 21 | 12895 ( 12700) 2000 for dup 5000 -osc while 22 | drop 1 . + next clang ; then 23 | : prep west a! ! 0 ! 24 | 0 0x20000 0x800 0x30800 0 0x20000 0x800 0x30800 25 | dup up a! drop 26 | : run !b !b @ drop run ; 27 | : main 28 | west a! 715 ! 29 | clang ; 30 | 31 | node 714 : wire @ !b wire ; : main east a! west b! 714 !b wire ; 32 | node 713 : wire @ !b wire ; : main east a! west b! 713 !b wire ; 33 | node 712 : wire @ !b wire ; : main east a! west b! 712 !b wire ; 34 | node 711 : wire @ !b wire ; : main east a! west b! 711 !b wire ; 35 | node 710 : wire @ !b wire ; : main east a! west b! 710 !b wire ; 36 | 37 | node 709 38 | : monitor 39 | ( print the test oscillation periods) 40 | @ dup !b 41 | if monitor then ( 0 means oscillation found) 42 | io b! 0 ( seconds ) 0 ( clock edge) 43 | : count ( counts seconds ) 44 | 0 !b up a! dup dup ! drop 45 | 0x800 !b up a! dup dup ! drop 46 | dup 32000 - 1 . + . + 47 | -if drop 1 . + count ; then 48 | drop over 1 . + dup west a! ! 0 count ; 49 | : main 50 | east a! west b! 709 !b 51 | monitor ; 52 | 53 | node 708 54 | : emit1 1 and 3 or !b 904 for unext ; 55 | : emit8 0 emit1 7 for dup emit1 2/ next 1 emit1 ; 56 | : emit18 0 emit8 drop emit8 emit8 emit8 ; 57 | : main io b! east a! 58 | : loop @ emit18 loop ; 59 | -------------------------------------------------------------------------------- /examples/crystal.aforth: -------------------------------------------------------------------------------- 1 | ( ga-load crystal.aforth /dev/ttyUSB3 460800 ) 2 | ( 32.768 khz watch crystal from 715.17 to GND ) 3 | 4 | node 715 5 | include 715crystal.aforth 6 | : run !b !b @ drop ( ADD CUSTOM CALLS HERE) run ; 7 | 8 | -------------------------------------------------------------------------------- /examples/fast-ram-node.aforth: -------------------------------------------------------------------------------- 1 | ( ga --run fast-ram-node.aforth 2 | ( 3 | ( 61 word ram node 4 | ( minimizes code needed in the client 5 | 6 | node 1 ( ram node 7 | /b west /a 0 8 | org 60 9 | : read 10 | a! @ !b 11 | : main 12 | @b -if: read 13 | - a! @b ! main ; 14 | 15 | 16 | node 0 ( test node 17 | /b east 18 | : write ( xa - ) 19 | - !b !b ; 20 | : read ( a - x ) 21 | !b @b ; 22 | : main 23 | 55 5 write 24 | 2 3 write 25 | 88 59 write 26 | 27 | 3 read . !!printT 28 | 59 read . !!printT 29 | 5 read . !!printT 30 | warm 31 | -------------------------------------------------------------------------------- /examples/flash-sim.el: -------------------------------------------------------------------------------- 1 | (setq _current-fragment nil) 2 | (setq _current-fragment-len nil) 3 | 4 | (setq _fragments (make-hash-table)) 5 | 6 | (defun _fragment (addr &rest words) 7 | (puthash addr words _fragments)) 8 | 9 | (setq _boot-fragment nil) 10 | (defun _boot (n) 11 | (setq _boot-fragment n)) 12 | 13 | (setq flash-file "flash.el") 14 | 15 | (let ((file (expand-file-name flash-file))) 16 | (if (file-exists-p file) 17 | (load file) 18 | (message "file %s does not exist" file) 19 | (kill-emacs))) 20 | 21 | (puthash 0 (gethash _boot-fragment _fragments) _fragments) 22 | 23 | (ga-define set-addr 24 | (let* ((addr (send node d-pop!)) 25 | (fragment (gethash addr _fragments))) 26 | (message "set-addr: %s" addr) 27 | (cond ((= addr #x3ffff) 28 | (message "(fragment request 0x3ffff)") 29 | (ga-stop-sim!)) 30 | 31 | ((not fragment) 32 | (message " Error: fragment %s not found" addr) 33 | (kill-emacs)) 34 | (t (setq _current-fragment-len (car fragment) 35 | _current-fragment (cdr fragment)))))) 36 | 37 | (ga-define read-len 38 | (message "read-len: %s" (1- _current-fragment-len)) 39 | (send node d-push! (1- _current-fragment-len))) 40 | 41 | (ga-define read-next 42 | (let ((x (car _current-fragment))) 43 | (message "read-next: %s" x) 44 | (unless (null x) 45 | (send node d-push! x) 46 | (setq _current-fragment (cdr _current-fragment))))) 47 | -------------------------------------------------------------------------------- /examples/lucas-series.aforth: -------------------------------------------------------------------------------- 1 | ( prints the first 15 numbers of the Lucas sequence ) 2 | ( ga-load lucas-series.aforth /dev/ttyUSB0 ) 3 | 4 | node 708 5 | include 708serial.aforth 6 | : main 7 | io b! south a! 8 | 15 for @ out18 drop next 9 | exit 10 | ( cold => 7.8mA ) 11 | ( warm => 3.6mA ) 12 | ( south a! ! ( =>2.3mA ) 13 | left a! ! ( => 0.015mA ) 14 | 15 | 16 | node 608 17 | north a! 2 1 over ! dup ! 18 | : lucas over over + dup ! lucas 19 | 20 | -------------------------------------------------------------------------------- /examples/node600-async.aforth: -------------------------------------------------------------------------------- 1 | ( 2 | ( demo using node 600 instead of 708 to send async data. 3 | ( useful in cases when node 708 pins are busy with something else. 4 | ( 5 | ( load code into target chip through node 300 using the host chip 6 | ( 7 | ( wire pin J30.4 to pin J23.11 8 | ( J23.11 is async out for port C 9 | ( J30.4 is for 600.17 10 | ( 11 | ( on eval board, bootstream is loaded into port A, data is read from port C 12 | 13 | ( ./cal node600-async.aforth /dev/ttyUSB0 -s 460800 -b async-target ) 14 | 15 | node 600 16 | include 600serial.aforth 17 | 18 | : main 19 | io b! east a! 20 | 15 for @ out18 drop next 21 | exit 22 | 23 | node 601 24 | io b! west a! 1 0 25 | : fib over over + dup ! fib 26 | -------------------------------------------------------------------------------- /examples/node709VCOM.aforth: -------------------------------------------------------------------------------- 1 | ( toggle 709.a0 at 10hz 2 | 3 | node 715 4 | /b io /a up 5 | : -osc 6 | for 7 | 0x30000 !b dup .. 2/ dup for unext 8 | 0x20000 !b .. over 1 and .. + for unext next 9 | dup or !b dup 30000 for 10 | drop @b - -while next ; 11 | then dup or pop drop ; 12 | : main 13 | : clang 14 | 12895 ( 12700) 2000 for dup 5000 -osc while 15 | drop 1 . + next clang ; then 16 | : prep 17 | 0 0x20000 0x800 0x30800 0 0x20000 0x800 0x30800 18 | : run !b !b @ drop run ; 19 | 20 | node 709 (709.a0 = j32.5 21 | /b io 22 | ( update vcom, send 10hz signal to 710 23 | (/stack 10 0x155 0x8AA 0x155 0x8AA 0x155 0x8AA 0x155 0x8AA 0x155 0x8AA 24 | ( 25 | : main 26 | 0x155 0x0AA 27 | 0 28 | : count 29 | up a! 30 | @low (0) !b dup ! 31 | @high (0x800) !b dup ! 32 | dup -3200 (-32000) . + 33 | -if drop 1 . + count ; then 34 | west a! 35 | drop drop 36 | update_vcom 37 | up a! 38 | 0 count ; 39 | : update_vcom 40 | over 41 | dup !low 42 | dup 0x800 . + !high 43 | dup ! ; 44 | : !low @p drop !p ; 45 | : @low @p ; 46 | , 0 47 | : !high @p drop !p ; 48 | : @high @p ; 49 | , 0x800 50 | 51 | node 7 ( d12 = J31.1 52 | : main 53 | data b! 54 | east a! 55 | \0x02800 \reset pin state 56 | 0x03800 \reset pin state 57 | \0x1000 58 | !b @ 59 | 60 | 61 | node 708 62 | : emit1 1 and 3 or !b 904 for unext ; 63 | : emit8 0 emit1 7 for dup emit1 2/ next 1 emit1 ; 64 | : emit18 0 emit8 drop emit8 emit8 emit8 ; 65 | : main io b! east a! 66 | : loop @ emit18 loop ; 67 | -------------------------------------------------------------------------------- /examples/port-execution.aforth: -------------------------------------------------------------------------------- 1 | ( code from AB004 2 | 3 | ( node 609 is in port execution mode and is used by node 608 4 | ( as a random access 64 word array 5 | 6 | node 609 7 | : main r--- 8 | 9 | node 608 10 | : set ( a ) 11 | @p ! ! ; 12 | .. @p a! .. 13 | : @next ( -n ) 14 | @p ! @ ; 15 | .. @+ !p .. 16 | : !next ( n ) 17 | @p ! ! ; 18 | .. @p !+ .. 19 | : fetch ( a-n ) set @next ; 20 | : store ( na ) set !next ; 21 | 22 | : main 23 | right a! 24 | 25 | ( store 2*i at index i 26 | 27 | 0 (index 28 | 10 for 29 | dup dup . + ( 2*index 30 | over ( index 31 | store 32 | 1 . + ( increment index 33 | next 34 | warm 35 | -------------------------------------------------------------------------------- /examples/probe-demo.el: -------------------------------------------------------------------------------- 1 | ;; ga probe-demo.el 2 | 3 | (setq code " 4 | node 705 5 | : x 0x3ffff !b 0x3fff0 !b ; 6 | : s . . . . ; 7 | : main 8 | io b! 9 | 10 for 10 | 0x2b !b 0x2a !b 11 | s 12 | 0x3a !b 0x3b !b 13 | x x x x x x 14 | s s s s 15 | next 16 | warm ; 17 | ") 18 | 19 | (setq assembled (assemble (aforth-compile code))) 20 | 21 | (setq chip (ga144-new "host")) 22 | (setq node705 (send chip coord->node 705)) 23 | 24 | (ga-connect-probe node705 0) 25 | (ga-connect-probe node705 1) 26 | (ga-connect-probe node705 2) 27 | (ga-connect-probe node705 3) 28 | 29 | (send chip load assembled) 30 | 31 | (ga144-step*) 32 | 33 | (ga144-probe-save) 34 | 35 | (when (file-exists-p "ga144-probe-graph.py") 36 | (shell-command "python ga144-probe-graph.py")) 37 | -------------------------------------------------------------------------------- /examples/reset-target-chip.aforth: -------------------------------------------------------------------------------- 1 | ( host 500.17 connected to target chip reset pin ) 2 | 3 | node 500 4 | : main 5 | 0x20000 io b! !b 6 | 200000 for . . . . next 7 | 0x0 !b 8 | warm 9 | -------------------------------------------------------------------------------- /examples/sensortag-listen.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python 2 | from sys import argv 3 | from serial import Serial 4 | import struct 5 | 6 | def read_seq(): 7 | print "" 8 | for i, name in enumerate(["acc X", "acc Y", "acc Z", 9 | "mag X", "mag Y", "mag Z", 10 | "gyro X", "gyro Y", "gyro Z", 11 | "therm", 12 | "misc", "???", "???"]): 13 | s = serial.read(4) 14 | (v, ) = struct.unpack("> 8) & 0xffff 17 | val2 = None 18 | if i < 3: 19 | if val >= 0x8000: 20 | val2 = float(0x10000 - val) / 0x20000 * 10 / 1.27 * 9.8 21 | else: 22 | val2 = float(val) / 0x20000 * 10 * -1 / 1.27 * 9.8 23 | #x = val & 0xfff 24 | #if x & 0x800: 25 | # x = ((v - 0x800) + 1)*(-1) 26 | print name, val, val2 or "" 27 | else: 28 | print "?????????" 29 | 30 | def listen(serial): 31 | while True: 32 | s = serial.read(4) 33 | (v, ) = struct.unpack("> 8) & 0x3ffff 36 | if val == 0x3ffff: 37 | read_seq() 38 | else: 39 | print "(unkown)",val 40 | elif (v & 0xff) == 1: 41 | print "[exit]" 42 | exit(0) 43 | else: 44 | print "unknown code:", v, v & 0xff 45 | 46 | if __name__ == "__main__": 47 | speed = 460800 48 | if len(argv) not in [2,3]: 49 | print "usage: ./listen.py port [speed={}]".format(speed) 50 | exit(1) 51 | if len(argv) == 3: 52 | speed = argv[2] 53 | port = argv[1] 54 | print "Listening. port={}, speed={}".format(port, speed) 55 | serial = Serial(port, speed) 56 | listen(serial) 57 | 58 | -------------------------------------------------------------------------------- /examples/sensortag.aforth: -------------------------------------------------------------------------------- 1 | ( Slightly modified code from Greenarrays's AN012. 2 | http://www.greenarraychips.com/home/documents/greg/AN012-130606-SENSORTAG.pdf 3 | 4 | Usage: 5 | 1. Connect the eval board USB ports A and C to your computer. 6 | 3. Run the script that print sensor readings sent from USB C on the eval board. 7 | python sensortag-listen.py USB_C 460800 8 | 3. compile and load: 9 | ./cal sensortag.aforth USB_A -s 460800 -b async-target 10 | Replace USB_A and USB_C with the actual port names. This can be found with dmesg 11 | The listen script must be started before loading. 12 | ) 13 | 14 | node 709 ( i2c timing ) 15 | /p 3 /b io /a up 16 | 17 | ( 18 | this dac actively pulls sensor scl line up and provides low energy 19 | timing for slow i2c bus. simple state machine receives one of two 20 | instrs from 708 thru right port. 21 | ) 22 | 23 | const pu or 3 0x15555 ( wait-high) 24 | const -pu or pu 0x800 ( wait-low ) 25 | : edge ( mn-mn) ( mn = 0x800, pu or -pu ) 26 | ( sets io state for wakeup, 27 | modify wakeup value on stack for opposite edge 28 | suspend on shared pin ) 29 | dup !b ( set wakeup state / DAC output ) 30 | over or 31 | ( @ drop ) 32 | dup 33 | ! ( shared pin wakeup ) 34 | ; 35 | : dun ( mn) 36 | ( ends a burst when act receives a call to, this defn. waits one clock 37 | phase before, entering idl for spacing.) 38 | r--- 39 | : idl 40 | ( idl state between bursts of i2c actvity. turns pull-up on and expects a 41 | return instruction. that does not delay 708 but we delay next, stim by at 42 | least one clock phase and enter, active state.) 43 | ( turn on pullup, wait for return instruction, 44 | read io reg, if high, wait for low edge, if low wait for high ) 45 | 46 | pu !b ( turn pullup on) 47 | ( ??? does it get turned off between burst? ) 48 | r--- ( call node 709 port, which receives a return instruction ) 49 | @b ( read io) 50 | pu ( used if pin is low ) 51 | over -if 52 | ( pin was high) 53 | -pu dup 54 | then 55 | drop ( drops extra -pu or io value to expose pu value) 56 | 0x800 over edge 57 | : act ( mn) 58 | ( act expects return instructions, delaying each 59 | by one clock phase after its predecessor ) 60 | edge r--- act ; 61 | 62 | node 708 ( slow i2c ) 63 | 64 | ( /a right /b io /p left) 65 | 66 | ( 67 | On boot, node 708 executes its left port to accept register initialization 68 | sequences for all the sensors from node 707, which has room for 25 8-bit 69 | register settings. [If more were needed, memory in node 706 could be used; 70 | or, if two modes of operation are contemplated, node 706 can supply an 71 | alternative initialization sequence.] After setting initial values in these 72 | registers, node 707 directs node 708 to execute its down port where the 73 | application hub will deliver on-line polling commands. Node 707 suspends 74 | until next boot. The code in node 708 provides a set of simple primitives 75 | for port execution 76 | ) 77 | ( clock pin: 708.17) 78 | ( data pin: 708.1 ) 79 | : main east a! io !b --l- ; 80 | 81 | : set ( n ) 82 | ( sets pins then waits 1/2 bit time ) 83 | !b @p ! ; .. ; 84 | : !hi ( n ) 85 | ( set with wait if clock stretched. ) 86 | dup begin over set 87 | ( loop until pin 17 is high) 88 | .. drop @b -until drop drop ; 89 | 90 | : c+d- 0x2 !hi ; 91 | ( c+d- etc...set bus state and delay. Any clock rise may be stretched) 92 | : c-d+ : c-d* 0x20000 set ; 93 | : c-d- 0x20002 set ; 94 | : c+d+ : c+d* 0 !hi ; 95 | 96 | : w1 ( n-n' ) 97 | ( xmit bit16 `i1' rcv bit1 both shift left.) 98 | 2* -if 99 | : wnak c-d+ c+d+ ; 100 | : wack then c-d- c+d- ; 101 | 102 | : w16 leap : w8 ( h.l-l.s ) 103 | ( xmit/shift bits 15-8, ret nak bit1.) 104 | then 7 for 2* w1 2/ next 105 | .. : i1 ( n-n+ ) c-d* c+d* @b 0x2 and or ; ( WHY OR? => building a full word) 106 | : strt : rest ( a.x-x.nak ) 107 | ( strt or restart chip a ) 108 | c-d+ c+d+ c+d- w8 ; 109 | : stop ( ends frame ) 110 | wack c+d+ @p ! ; .. dun@709 ; 111 | 112 | : !af ( a.i-s ) 113 | ( starts reg write, use `w8', `w16' as needed then `stop' ) 114 | strt w8 ; 115 | : r8 ( -n ) 7 for 2* i1 next ; 116 | : zr8+ ( -n ) dup dup or : r8+ ( n-n ) r8 wack ; 117 | 118 | ( port executable functions, 119 | all of these require port execution, help to deliver args and results ) 120 | : @regs ( a.i-ss ) 121 | ( starts burst read of chip a reg i) 122 | dup 0x100 or ( WHY '0x100 or'? ) 123 | .. push !af pop rest ; 124 | : @w+ ( -n ) 125 | ( @w+ reads 16 bits msb first into bits 16-1 ) 126 | zr8+ r8+ ; 127 | 128 | : @w. ( -n ) 129 | ( @w. @b. read final word/byte to 8-1) 130 | zr8+ : @b. ( n-n' ) r8 wnak stop ; 131 | 132 | node 707 ( sensor init) 133 | ( /b left /a 0 ) 134 | ( this node initializes all sensors after reset 135 | by storing register values) 136 | 137 | ( ( host ) ( : /t here 2/ -1 + ; ( target) 138 | 139 | ( table starting at zero holds up to 25 2-word, 140 | entries, one for each 8/16-bit register 141 | 142 | ...+0 00 aaaa aaa0 iiii iiii busadr, index, 143 | ...+1 w0 1111 1111 2222 2222 wordflg, byte1,2, 144 | ...first section of tbl disables all sensors, 145 | 146 | on boot, node 708 executes left port to catch 147 | ..these commands. after exhausting the table, 148 | ..we direct node 708 to down for on-line work 149 | ) 150 | ( stby acc ) , 0x1e1b , 0 ( mag ) , 0x1c10 , 0 151 | ( gyro) , 0xd03e , 0x4000 ( therm) , 0x8802 , 0x20400 152 | ( /t everything standby) 153 | ( acc ) , 0x1e1b , 0 ( 0x4000) , 0x1e21 , 0 154 | , 0x1e1b , 0x8000 ( 0xc000) 155 | ( srst acc ) ( , 0x1e1d , 0x8000) 156 | ( /t enables for condition yellow) 157 | ( mag ) , 0x1c11 , 0xa000 , 0x1c10 , 0xc100 158 | ( gyro) , 0xd03e , 0 ( therm) , 0x8802 , 0x27400 159 | ( /t) ( enables for alerted mode) 160 | ( (&!rs ( address of !rs) ( ( org ( make sure room!,) 161 | : main 162 | east b! dup dup or a! 163 | : !rs 10 ( /t above) for 164 | @p !b @+ 165 | .. @p !af@708 .. 166 | !b @+ dup @p 167 | .. @p .. 168 | !b !b 169 | .. -if @p !b .. 170 | w8@708 171 | then 172 | @p !b @p 173 | .. w8@708 174 | .. stop@708 .. 175 | !b next 176 | .. @p !b 177 | .. -d-- 178 | .. warm ; 179 | 180 | 181 | node 608 ( poll, distrib ) 182 | ( /p 0x29 /b down /a 0) 183 | 184 | ( 185 | 608 performs normal data polling as commanded 186 | by 607. the primitive is burst read of 16-bit 187 | words. node 708 is commanded to do the burst, 188 | read; the resulting data are passed to nodes, 189 | 609, for internal distribution, and 508, for, 190 | prototype raw data logging., 191 | ) 192 | 193 | : @r; ( a.i) 194 | ( @r; starts a burst on chip a register i ) 195 | ( called by node 608 with addr value from its main table) 196 | @p !b !b ; 197 | .. @p @regs@708 .. 198 | : 1w+ ( -n ) 199 | @p !b ( call @w+ in node 708 ) 200 | .. @w+@708 .. 201 | @p !b @b ; ( retrieve the result from 708) 202 | .. 2/ !p 203 | : 1w. ( -n ) 204 | @p !b 205 | .. @w.@708 .. 206 | @p !b @b ; 207 | .. 2/ !p 208 | ( : dlv up a! dup .. ! right a! .. ! ;) 209 | : dlv south a! ! ; 210 | : @nw ( n ) 211 | ( @nw bursts n+1 words with msb in first reg; ) 212 | push begin zif 1w. dlv ; 213 | then 1w+ dlv end 214 | : swb ( n ) ( swap bytes) 215 | push 0xffff dup dup or 216 | pop dup 2* 2* a! 217 | 9 for +* unext drop drop a and dlv ; 218 | 219 | : @nbs ( n ) 220 | ( @nbs bursts with lsb in first reg; on sensor, 221 | ...tag, only accelerometer works this way. ) 222 | push begin zif 1w. swb ; 223 | then 1w+ swb end 224 | : seq ( n a.i ) 225 | ( seq finishes a burst after @r; n neg is ones, 226 | ...complement of count for @nbs.,) 227 | ( @r; ) -if - @nbs ; then @nw ; 228 | : main 229 | down b! 230 | : stm 231 | ( stm waits for next cycle, passing stimulus, 232 | ...from 609 to 607 and slaving to 607) 233 | right a! @ south a! 0x3ffff ! left a! ! --l- ; 234 | ( reclaim ) ( exit ) 235 | 236 | 237 | node 607 ( poll sequencer ) 238 | ( host : /t here 2 / -1 + ; : /- - ; target ) 239 | 240 | ( table of up to 24 bursts,) 241 | ( acc) , 0x1e06 , 0x3fffd ( 2 /-) 242 | ( mag) , 0x1c01 , 2 243 | ( gyro) , 0xd01d , 2 244 | ( therm) , 0x8801 , 0 , 0x8800 , 0 245 | ( misc) , 0x1e0f , 0 ( , 8802 , 0) , 0x1c07 , 0 246 | 247 | : main left b! 248 | : !rs ( /t above) 249 | @b dup or a! ( read 608, store 0 in a ) 250 | 251 | 6 for ( loop for each table item ) 252 | @p !b @+ 253 | .. @p @r;@608 .. 254 | !b 255 | 256 | @p !b 257 | .. @p seq@608 .. 258 | @+ !b 259 | next 260 | 261 | @p !b 262 | .. stm@608 263 | !rs ; 264 | 265 | 266 | 267 | node 715 268 | : -osc over 269 | io b! for 270 | 0x30000 !b dup .. 2/ dup for unext 271 | 0x20000 !b .. over 1 and .. + for unext next 272 | dup or !b dup 30000 for 273 | drop @b - -while next ; 274 | then dup or pop drop ; 275 | : clang 276 | 12470 2000 for dup 5000 -osc while 277 | drop 1 . + next clang ; then 278 | : prep 279 | 0 0x20000 0x800 0x30800 0 0x20000 0x800 0x30800 280 | dup up a! drop 281 | : run !b !b @ drop run ; 282 | : main south a! clang ; 283 | 284 | 285 | node 717 ( hub timing ) 286 | 287 | const pu or 3 0x15555 ( io for wait-high ) 288 | const -pu or pu 0x800 ( io for wait-low ) 289 | 290 | : main -pu pu over over 291 | over over over over over up a! !b warm ; 292 | : dly ( n ) push begin dup dup ! drop !b next ; 293 | 294 | node 617 ( hub control ) 295 | 296 | : wait ( n) 297 | ( `dly` waits 5 seconds for boot to finish., 298 | time delay actually starts when the oscillator 299 | node begins exciting the crystal. while delay, 300 | runs, node 517 resets ble chip which we assume 301 | is open for business within five seconds. uses 302 | `wait` which delays n halfcycles of watch xtal. ) 303 | ( 11111 !b dup !b ) 304 | .. @p ! ! 305 | .. @p dly@717 306 | .. @p ! 307 | .. . 308 | .. ; 309 | 310 | : main north a! west b! 311 | : dly 4 for 65536 wait next 312 | : run 65536 wait 1 !b run 313 | 314 | node 616 : wire @ !b wire ; : main east a! west b! 616 !b wire ; 315 | 316 | node 615 317 | ( reads from 715 until resonance is found, then from 616 ) 318 | : wire1 @ if !b wire1 then !b 8888 !b east a! 319 | : wire @ !b wire ; 320 | ( : main north a! west b! 615 !b wire1 ; ) 321 | : main east a! west b! wire ; 322 | 323 | node 614 : wire @ !b wire ; : main east a! west b! wire ; 324 | node 613 : wire @ !b wire ; : main east a! west b! 613 !b wire ; 325 | node 612 : wire @ !b wire ; : main east a! west b! 612 !b wire ; 326 | node 611 : wire @ !b wire ; : main east a! west b! 611 !b wire ; 327 | node 610 : wire @ !b wire ; : main east a! west b! 610 !b wire ; 328 | node 609 : wire @ !b wire ; : main east a! west b! 609 !b wire ; 329 | ( node 509 : wire @ !b wire ; : main north a! west b! 608 !b wire ; ) 330 | ( node 508 : wire @ !b wire ; : main east a! west b! 608 !b wire ; ) 331 | node 508 : wire @ !b wire ; : main north a! west b! 608 !b wire ; 332 | node 507 : wire @ !b wire ; : main east a! west b! 607 !b wire ; 333 | node 506 : wire @ !b wire ; : main east a! west b! 606 !b wire ; 334 | node 505 : wire @ !b wire ; : main east a! west b! 605 !b wire ; 335 | node 504 : wire @ !b wire ; : main east a! west b! 604 !b wire ; 336 | node 503 : wire @ !b wire ; : main east a! west b! 603 !b wire ; 337 | node 502 : wire @ !b wire ; : main east a! west b! 602 !b wire ; 338 | node 501 : wire @ !b wire ; : main east a! west b! 601 !b wire ; 339 | node 500 : wire @ !b wire ; : main east a! north b! 601 !b wire ; 340 | 341 | node 600 ( async out) 342 | : val 1 and if 0x20000 ; then 0x30000 ; 343 | : out18 0 out8 drop out8 out8 344 | : out8 0 out1 7 for dup out1 2/ next 1 345 | : out1 val !b drop 865 for unext ; 346 | : exit 1 out8 347 | : main io b! south a! 600 out18 348 | : loop @ out18 loop 349 | 350 | 351 | node 705 352 | : main io b! 0 !b 353 | 354 | node 300 355 | : main io b! 0 !b 356 | -------------------------------------------------------------------------------- /examples/sram-demo.aforth: -------------------------------------------------------------------------------- 1 | ( save words to sram then read them back and print them 2 | 3 | ( 708 - async, print all words it receives from south port 4 | ( 106 - for n from 1 to 10 write sram[n] = 2*n 5 | ( for n from 1 to 15 read sram[n], sent to node 708 6 | ( 107,7,8,9 - sram control 7 | ( 608...206 - wire nodes for sending data from sram to async port 8 | 9 | ( run with: 10 | ( ./ga-load examples/sram-demo.aforth /dev/ttyUSB0 11 | ( Exected output: 12 | ( 0 13 | ( 2 14 | ( 4 15 | ( 6 16 | ( 8 17 | ( 10 18 | ( 12 19 | ( 14 20 | ( 16 21 | ( 18 22 | ( 20 23 | ( ... 24 | ( ... 25 | ( ... 26 | ( ... 27 | ( ... 28 | ( [exit] 29 | ( Where ... are random numbers 30 | 31 | 32 | 33 | ( ( block 278: 34 | ( example code for memory master nodes. 35 | ( memory-access words assume that addresses and 36 | ( data are 16-bit parameters with the upper two 37 | ( bits zero and pages are 4-bits with the upper 38 | ( 14 bits zero. p.a is thus a 20-bit address. 39 | ( 40 | ( ex@ a p - w fetch w from p.a 41 | ( ex! w a p store w at p.a 42 | ( mk! w f -0 set masks from w per f. 43 | ( cx? w a p n - f comp-and-exch 44 | ( 45 | ( cx? compares value at p.a to n. if same, write 46 | ( s w to p.a and returns true. otherwise, only 47 | ( returns false. x@ and x! are 16-bit versions to 48 | ( access the lowest 64k of available memory. 49 | ( 50 | ( mk! sets mask from w when f is 0; 51 | ( posts stimuli when f is 1. ) 52 | ( - user )node 106 ( node 106, 108, or 207.) 53 | : x! ( wa) ( 39) dup dup or 54 | : ex! ( wap) : mk! ( mfp') ( 3A) - !b - !b !b ; 55 | : x@ ( a-w) ( 3C) dup dup or 56 | : ex@ ( ap-w) ( 3D) !b !b @b ; 57 | : cx? ( wapn-f) ( 3E) - !b !b !b !b @b ; ( 40) 58 | : main 59 | north a! east b! 60 | 0 10 for dup dup . + over x! 1 . + next 61 | 0 15 for dup dup x@ ! 1 . + next 62 | warm 63 | 64 | 65 | include sram.aforth 66 | include sram-minimal-master.aforth 67 | 68 | 69 | node 708 70 | include 708serial.aforth 71 | : main 72 | io b! south a! 73 | 15 for @ out18 next 74 | exit warm ; 75 | 76 | 77 | node 608 : main north b! south a! : loop @ !b loop ; 78 | node 508 : main north b! south a! : loop @ !b loop ; 79 | node 408 : main north b! south a! : loop @ !b loop ; 80 | node 308 : main north b! west a! : loop @ !b loop ; 81 | node 307 : main west a! east b! : loop @ !b loop ; 82 | node 306 : main south a! east b! : loop @ !b loop ; 83 | node 206 : main south a! north b! : loop @ !b loop ; 84 | -------------------------------------------------------------------------------- /examples/stack.aforth: -------------------------------------------------------------------------------- 1 | node 1 ( stack node) 2 | /p west /a 63 3 | org 0 4 | : Spush 5 | -1 a . + a! ! ; 6 | 7 | node 0 ( client node) 8 | /b east 9 | : Spop 10 | @p !b @b 11 | .. @+ !p .. 12 | ; 13 | : Spush 14 | @p !b !b @p 15 | .. @p .. 16 | .. Spush@1 .. 17 | !b ; 18 | 19 | : main 20 | 1 Spush 2 Spush 3 Spush 21 | Spop Spop Spop 22 | 5 Spush 23 | -------------------------------------------------------------------------------- /examples/test-print.aforth: -------------------------------------------------------------------------------- 1 | \ ga test-print.aforth --run 2 | \ 3 | \ calculate the Fibonacci sequence and print the results 4 | \ demo loading a lisp file and calling a lisp function 5 | \ with the !! syntax 6 | 7 | include test-print.el 8 | 9 | node 0 10 | : main 11 | 1 1 12 | 10 for 13 | over over + !!showT 14 | next 15 | 16 | warm 17 | 18 | 19 | -------------------------------------------------------------------------------- /examples/test-print.el: -------------------------------------------------------------------------------- 1 | 2 | ;; functions used in the test-print.aforth and test-print2.aforth examples 3 | 4 | (ga-define showT 5 | (princ (format "%s\n" (car (send node get-dstack-as-list))))) 6 | 7 | (setq __s nil) 8 | 9 | (ga-define saveT 10 | (push (car (send node get-dstack-as-list)) __s) 11 | ) 12 | 13 | (ga-define end 14 | (princ (format "%s\n" __s)) 15 | ) 16 | 17 | 18 | -------------------------------------------------------------------------------- /examples/test-print2.aforth: -------------------------------------------------------------------------------- 1 | ( ga test-print2.aforth --run ) 2 | include test-print.el 3 | 4 | node 0 5 | : main 6 | 1 1 7 | 10 for 8 | over over + !!saveT 9 | next 10 | warm !!end 11 | 12 | -------------------------------------------------------------------------------- /examples/variables.aforth: -------------------------------------------------------------------------------- 1 | node 1 2 | : var! @p drop !p ; 3 | : var@ 0 ; 4 | 5 | : main 6 | 5 var! ( set variable 7 | var@ ( read variable 8 | 9 | var@ . + var! 10 | 11 | 12 | -------------------------------------------------------------------------------- /examples/vm.aforth: -------------------------------------------------------------------------------- 1 | ( adapted from https://github.com/jamesbowman/ga144tools/blob/master/src/nt.ga 2 | 3 | include flash-sim.el 4 | 5 | node 705 ( test flash controller that calls the lisp simulation 6 | 7 | /a east /b io /stack 2 0x2b 0x2a 8 | : main 9 | : again 10 | 0xc00 drop \cmd \ 0xc00 = eval(`0x03 << 10') \ read 11 | ( !!break 12 | south a! @ 13 | \ 24o 14 | . !!set-addr 15 | dup push 16 | over over over 17 | over over over 18 | 19 | east a! 20 | \in8 21 | . !!read-len 22 | pop ! 23 | dup ! 24 | 25 | 63 and for 26 | \in18 27 | . !!read-next 28 | ! next 29 | again ; 30 | 31 | : cmd \ n- 32 | 0x2f !b 0x2b !b 33 | 7 push 34 | oloop ; 35 | : 24o 36 | 23 push 37 | : oloop 38 | -if 39 | 2* 0x3a !b 0x3b 40 | !b next: oloop 41 | drop ; 42 | then \ tx0 43 | 44 | push dup !b 45 | over !b pop 46 | 2* next: oloop 47 | drop ; 48 | 49 | . 50 | 51 | : in8 52 | dup dup or 7 53 | push inloop ; 54 | 55 | : in18 56 | 17 push dup 57 | 58 | : inloop 59 | push !b !b 60 | pop @b -if: got0 61 | drop - 2* 62 | - next: inloop 63 | ; 64 | : got0 65 | drop 2* next: inloop 66 | ; 67 | \ 68 | \node 705 69 | \\ See block 1428 for ROM definitions 70 | \\ For usage notes: 71 | \\ https://mschuldt.github.io/www.colorforth.com/flash.htm 72 | \\ http://ww1.microchip.com/downloads/en/DeviceDoc/25024C.pdf 73 | \\ EVB001 note: check jumpers J20 and J26 74 | \ 75 | \/a east /b io /stack 2 0x2b 0x2a 76 | \: main 77 | \: again 78 | \ 0xc00 cmd \ 0xc00 = eval(`0x03 << 10') \ read 79 | \ south a! @ 80 | \ 24o 81 | \ dup push 82 | \ over over over 83 | \ over over over east 84 | \ a! in8 85 | \ pop ! 86 | \ dup ! 87 | \ 88 | \ 63 and for in18 ! next 89 | \ again ; 90 | \ 91 | \: cmd \ n- 92 | \ 0x2f !b 0x2b !b 93 | \ 7 push 94 | \ oloop ; 95 | \: 24o 96 | \ 23 push 97 | \: oloop 98 | \ -if 99 | \ 2* 0x3a !b 0x3b 100 | \ !b next: oloop 101 | \ drop ; 102 | \then \ tx0 103 | \ 104 | \ push dup !b 105 | \ over !b pop 106 | \ 2* next: oloop 107 | \ drop ; 108 | \ 109 | \ . 110 | \ 111 | \: in8 112 | \ dup dup or 7 113 | \ push inloop ; 114 | \ 115 | \: in18 116 | \ 17 push dup 117 | \ 118 | \: inloop 119 | \ push !b !b 120 | \ pop @b -if: got0 121 | \ drop - 2* 122 | \ - next: inloop 123 | \ ; 124 | \: got0 125 | \ drop 2* next: inloop 126 | \ ; 127 | 128 | node 506 129 | \ attr: render color 0 .3 .3 130 | /b north /p north 131 | 132 | . .. ( jump NORTH 133 | 134 | : addr \ ( -- o ) 135 | \ fetch byte address 0-383 136 | \ set A to bank 137 | \ o to offset 0-63 138 | 2/ dup 2/ 139 | 2/ 2/ 2/ 140 | 2/ 2/ tab 141 | , 373 \west 142 | , 277 \south 143 | , 469 \east 144 | : tab 145 | pop + a! 146 | @ a! 147 | 63 and ; 148 | 149 | : @ 150 | @b addr 151 | .. @p ! ! 152 | .. @p a! @ !p .. 153 | @ !b ; 154 | 155 | : ! 156 | @b addr 157 | .. @p ! ! @p 158 | .. @p a! . . .. 159 | .. @p ! . . .. 160 | ! @b ! ; 161 | 162 | : c@ 163 | @b dup dup addr 164 | .. @p ! ! 165 | .. @p a! @ !p .. 166 | 2/ 2* or \ low bit of addr 167 | 2* 2* 2* \ 0 or 8 168 | push @ next: hibyte 169 | : lo8 170 | 255 and !b ; 171 | 172 | : hibyte 173 | begin 2/ unext lo8 ; 174 | 175 | : c! 176 | @b dup addr 177 | .. @p ! ! 178 | .. @p a! . . .. 179 | ! @b ! ; 180 | 181 | \ The three banks for the RAM 182 | node 505 183 | \ attr: render color .3 .3 0 184 | /p east 185 | , 50502 186 | , 50504 187 | 188 | node 507 189 | \ attr: render color .3 .3 0 190 | /p west 191 | , 50702 192 | , 50704 193 | 194 | node 406 195 | \ attr: render color .3 .3 0 196 | /p north 197 | , 40602 198 | , 40604 199 | 200 | 201 | node 605 202 | \ R stk 203 | /b north /a 50 \ TODO: fix, temp value for testing,should be RSTACKTOP 204 | /p east \ port exe from X 205 | 206 | .. . 207 | .. . 208 | .. . 209 | .. . 210 | .. . 211 | .. . 212 | .. . 213 | .. . 214 | .. . 215 | .. . 216 | .. . 217 | .. . 218 | .. . 219 | .. . 220 | .. . 221 | .. . 222 | .. . 223 | .. . 224 | .. . 225 | .. . 226 | .. . 227 | .. . 228 | .. . 229 | .. . 230 | .. . 231 | .. . 232 | .. . 233 | .. . 234 | .. . 235 | .. . 236 | .. . 237 | .. . 238 | .. . 239 | .. . 240 | .. . 241 | .. . 242 | .. . 243 | .. . 244 | .. . 245 | .. . 246 | .. . 247 | .. . 248 | .. . 249 | .. . 250 | .. . 251 | .. . 252 | .. . 253 | .. . 254 | .. . 255 | .. . 256 | .. . 257 | .. . 258 | .. . 259 | .. . 260 | .. . 261 | .. . 262 | .. . 263 | .. . 264 | .. . 265 | : RSTACKTOP 266 | : RETURN 267 | @+ !b ; 268 | : RPUSH 269 | -1 a + 270 | a! ! ; 271 | 272 | node 606 273 | \ D stk and execute 274 | /b west 275 | \ /a STACKTOP 276 | /a 40 \ approx for testing 277 | /stack 1 0x947 278 | : main 279 | : again 280 | 0 GO 281 | -d-- ; \jump NORTH \ port exe from D 282 | .. . 283 | .. . 284 | .. . 285 | .. . 286 | .. . 287 | .. . 288 | .. . 289 | .. . 290 | .. . 291 | .. . 292 | .. . 293 | .. . 294 | .. . 295 | .. . 296 | .. . 297 | .. . 298 | .. . 299 | .. . 300 | .. . 301 | .. . 302 | .. . 303 | .. . 304 | .. . 305 | .. . 306 | .. . 307 | .. . 308 | .. . 309 | .. . 310 | .. . 311 | .. . 312 | .. . 313 | .. . 314 | .. . 315 | .. . 316 | .. . 317 | .. . 318 | .. . 319 | .. . 320 | : STACKTOP 321 | : TO_R 322 | @p !b !b ; 323 | .. @p RPUSH@605 324 | : DORETURN 325 | @p !b ; 326 | .. RETURN@605 327 | : IFELSE \ a b f : if [f] a else b 328 | if: TWOD 329 | drop 330 | : TWOD 331 | drop 332 | : GO 333 | @p !b !b ; 334 | .. @p !b 335 | : LIT 336 | over 337 | : -! 338 | -1 a + a! ! ; 339 | : 18shr 340 | 8 push 341 | 2/ 2/ unext ; 342 | : swap 343 | over push over 344 | or or pop 345 | -d-- ; \ jump NORTH \ why? 346 | 347 | 348 | node 706 349 | /a west /b south 350 | : again 351 | @ @ 352 | dup 9 push 353 | begin 2* unext 354 | -if: noreturn 355 | ( . !!break 356 | .. @p !b 357 | .. DORETURN@606 .. 358 | : noreturn 359 | drop 360 | 63 and push 361 | begin @ !b unext 362 | again ; 363 | 364 | \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 365 | \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 366 | 367 | node 608 368 | /a west /b east 369 | run ; 370 | emit ; 371 | \!b @b ! ; ( wait ) 372 | wait ; 373 | : run @ dup (!b) push ex run ; 374 | : emit north b! @ !b east b! ; 375 | : wait !b @ !b @ !b @b ! ; 376 | 377 | 378 | node 609 379 | /a west /b east 380 | main ; 381 | ; ( emit ) 382 | \!b @b ! ; ( wait ) 383 | wait ; ( wait ) 384 | : main 385 | : run @ dup (!b) push ex run ; 386 | : wait !b @ !b @ !b @b ! ; 387 | 388 | 389 | node 610 390 | /a west /b east 391 | main ; 392 | ; ( emit ) 393 | wait ; ( wait ) 394 | : main 395 | : run @ dup push ex run 396 | : wait 397 | north b! 398 | !b @ !b @ !b @b ! 399 | east b! 400 | ; 401 | 402 | 403 | 404 | node 607 405 | /a west /b east 406 | run ; 407 | @ drop ; ( emit ) 408 | wait ; 409 | : main 410 | : run @ dup (!b) push ex run ; 411 | : wait @ !b @ !b @b ! ; 412 | -------------------------------------------------------------------------------- /examples/watch-crystal-counter-test.aforth: -------------------------------------------------------------------------------- 1 | ( ga --run watch-crystal-counter-test.aforth 2 | ( 3 | ( Tests a watch counter 4 | ( Crystal frequency: 32768Hz 5 | ( node 0 supplies stream of words to simulate the crystal pulses 6 | ( node 1 waits for each pulse and increments its counter 7 | ( node 2 receives words 8hz and 1second intervals 8 | ( 0 used for 8hz signal, <0 used for 1 second signal 9 | node 0 ( test node) 10 | /a east 11 | : main ! main ; 12 | 13 | node 2 ( test node) 14 | /a west 15 | : main @ !!printT main ; 16 | 17 | 18 | node 1 19 | /a west /b east 20 | /stack 6 0 2 2 2 2 2 21 | : main 22 | : inc 23 | @ drop 24 | 2* -if drop 25 | ( 2048Hz 26 | 2* -if drop 27 | ( 128Hz 28 | 2* -if (drop) 29 | ( 8hz) dup or !b 30 | 2* 2* -if (drop) 31 | (1s) !b 32 | 2* -if drop 33 | 16s 34 | two then 35 | two then 36 | two then 37 | two then 38 | two then 39 | inc ; 40 | : two 2 ; 41 | : 16s 42 | 1 . + dup -225 . + -if drop ; 43 | then @hours 1 . + !hours dup or ; 44 | : !hours @p drop !p ; 45 | : @hours @p ; 46 | , 0 47 | 48 | ( TODO: use rstack as a a stream of 2s ) 49 | -------------------------------------------------------------------------------- /ga: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mschuldt/ga144/5b327b958f5d35cf5a015044e6ee62f46446169f/ga -------------------------------------------------------------------------------- /ga-load: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python 2 | 3 | from sys import argv 4 | import subprocess 5 | from serial import Serial 6 | 7 | def write(bs, serial): 8 | serial.write(bs) 9 | 10 | #18bit words transmitted using 4 bytes with format: 11 | # upper2 middle8 lower8 wordcode 12 | # 13 | # wordcodes: 14 | # 0: receive 18 bit word 15 | # 1: exit 16 | def listen(port, speed, serial, verbose=True): 17 | if verbose: 18 | print "Listening. port={}, speed={}".format(port, speed) 19 | 20 | def read_n( n ): 21 | x = [ord(serial.read( 1 )) for _ in range( n ) ] 22 | x.reverse() 23 | word = 0 24 | for byte in x: 25 | word = ( word << 8 ) | byte 26 | n -= 1 27 | return word 28 | 29 | while True: 30 | n = read_n( 1 ) 31 | if n == 1: 32 | print "[exit]" 33 | return 34 | if n == 0: 35 | n = read_n( 3 ) 36 | print n & 0x3ffff 37 | else: 38 | print "ERROR -- unknown code:", n 39 | 40 | def run_command(cmd): 41 | p = subprocess.Popen(cmd, stdout=subprocess.PIPE, shell=True) 42 | x = p.communicate()[0] 43 | return x.strip() 44 | 45 | default_speed = 460800 46 | bootstream_types = [ "async", "2wire", "async-target" ] 47 | bootstream_type = "async" 48 | 49 | def print_usage_and_exist(): 50 | print "usage: ./ga-load filename port [--speed (default: {})] [--bootstream (default: {})] [--no-listen]".format(default_speed, bootstream_type) 51 | exit(1) 52 | 53 | if __name__ == "__main__": 54 | 55 | #speed = 921600 56 | if len(argv) not in [3, 4, 5, 7]: 57 | print_usage_and_exist() 58 | 59 | filename = argv[1] 60 | port = argv[2] 61 | 62 | speed = default_speed 63 | 64 | argv = argv[3:] 65 | serial_listen = True 66 | if "--no-listen" in argv: 67 | arg.remove("--no-listen") 68 | serial_listen = False 69 | if not (len(argv) % 2 == 0): 70 | print_usage_and_exist() 71 | 72 | while argv: 73 | arg = argv.pop(0) 74 | if arg == "--speed" or arg == "-s": 75 | speed = int(argv.pop(0)) 76 | elif arg == "--bootstream" or arg == "-b": 77 | bootstream_type = argv.pop(0) 78 | if bootstream_type not in bootstream_types: 79 | print "invalid bootstream type:", bootstream_type 80 | exit(1) 81 | else: 82 | print "invalid option: ", arg 83 | 84 | cmd = "ga --bootstream-type {} --only-bootstream {}".format(bootstream_type, filename) 85 | bootstream = run_command(cmd).split(" ") 86 | if "DEBUG" in bootstream: 87 | print "Error: compiler debug mode must be disabled" 88 | exit(1) 89 | host = Serial(port, speed) 90 | # target chip serial for resetting 91 | target = None #Serial("/dev/ttyUSB4", 921600) 92 | write("".join(map(lambda x: chr(int(x)), bootstream)), host) 93 | if serial_listen: 94 | listen(port, speed, host) 95 | host.close() 96 | 97 | 98 | # ./ga-load test.aforth /dev/ttyUSB3 --speed 460800 --bootstream async-target 99 | -------------------------------------------------------------------------------- /ga-sim: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mschuldt/ga144/5b327b958f5d35cf5a015044e6ee62f46446169f/ga-sim -------------------------------------------------------------------------------- /lib/600serial.aforth: -------------------------------------------------------------------------------- 1 | ( wire pin J30.4 to pin J23.11 2 | ( J23.11 is async out for port C 3 | ( J30.4 is for 600.17 4 | 5 | : val 1 and if 0x20000 ; then 0x30000 ; 6 | : out18 0 out8 drop out8 out8 7 | : out8 0 out1 7 for dup out1 2/ next 1 8 | : out1 val !b drop 865 for unext ; 9 | : exit 1 out8 10 | -------------------------------------------------------------------------------- /lib/708serial.aforth: -------------------------------------------------------------------------------- 1 | ( b must be set to io) 2 | : out18 ( n - n ) 3 | ( 18bit words sent using 4 bytes in this order: wordcode lower8 middle8 upper2) 4 | 0 out8 drop 5 | out8 out8 6 | : out8 ( n - n ) 7 | 0 out1 8 | 7 for dup out1 2/ next 1 9 | : out1 ( n ) 10 | 1 and 3 or !b 11 | 904 for unext ; ( unext delay = [1/baud_rate]/[2.4*10^-9] ) 12 | : exit 1 out8 ; 13 | -------------------------------------------------------------------------------- /lib/715crystal.aforth: -------------------------------------------------------------------------------- 1 | ( shared code for driving the crystal 2 | ( see examples/crystal.aforth for how to use it 3 | 4 | ( taken from colorforth block 980 ) 5 | 6 | ( 32.768 khz watch crystal from 715.17 to gnd ) 7 | : -osc ( kn-f ) 8 | ( -osc tries exciting the crystal with n cycles of period k returning nonzero 9 | ( if it didn't come back high after last cycle ) 10 | io b! for 11 | 0x30000 !b dup .. 2/ dup for unext 12 | 0x20000 !b .. over 1 and .. + for unext next 13 | dup or !b dup 30000 for 14 | drop @b - -while next ; 15 | then dup or pop drop ; 16 | : main 17 | : clang 18 | ( clang searches for resonant frequency over a reasonable range. 19 | ( Initially we use 5000 cycles and may be able to shorten this. When we find 20 | ( resonance, falls thru into 'prep' which sets up registers and finally we 21 | ( camp in 'run' which is the low power, low duty cycle oscillator ) 22 | 12700 200 for dup 5000 -osc while 23 | drop 1 . + next clang ; then 24 | : prep 0 0x20000 0x800 0x30800 0 0x20000 0x800 0x30800 25 | dup up a! drop 26 | ( : run !b !b @ drop run ; ( <= must be provided after including this file 27 | 28 | ( : try ( test code for finding resonance) 29 | ( dup 5000 -osc over 1 . + ; 30 | 31 | ( do not connect any kind of conventional probe to the crystal; this oscillator 32 | ( will not work if you load it down even that much) 33 | ( => successfully tested with the Agilent MSO-X 2014A oscilloscope ) 34 | -------------------------------------------------------------------------------- /lib/__test.aforth: -------------------------------------------------------------------------------- 1 | ( This file is for testing the include feature *DO NOT CHANGE* ) 2 | 3 | @p 4 | : x + ; 5 | : xx x ; 6 | - -------------------------------------------------------------------------------- /lib/sram-minimal-master.aforth: -------------------------------------------------------------------------------- 1 | 2 | ( node 107 minimal capability version. cr 3 | ( single master, no polling, no stimuli. cr 4 | ( maximum speed, minimum power. 5 | ( 6 | ( all requests are atomic. passes ex@ and ex! cr 7 | ( requests on to node 007, performs cx? locally 8 | ( using those primitives. 9 | ( 10 | ( requests are variable length messages decoded 11 | ( as shown below where - means 18-bit inverse of 12 | ( 16 bit argument. 13 | ( 14 | ( ex@ +p +a fetch 15 | ( cx? -w1 +p a w2 comp-and-exch 16 | ( ex! -p -a w store 17 | ( 280 list degenerate sram 107 node 18 | 19 | node 107 org 0 20 | 21 | : cx ( wp-) over push @ dup 22 | ( a) !b over ( p) !b @b ( w) pop - ( w1) or if 23 | ( ne) @ ( w2) dup or ( ff) ! ; 24 | ( eq) then drop ( a) !b - ( -p) !b @ ( w2) !b 0xffff ! ; 25 | 26 | : cmd @ -if @ ' cx -until ( .e!) - !b !b @ !b ; 27 | then @ ( .. here to conform with softsim ) ( .e@) ( a) !b ( p) !b @b ( w) ! ; 28 | ( TODO: in softsim the '@' after 'then' is in its own word, why? 29 | org 0x17 30 | 31 | : main : start down b! right a! 32 | : run cmd run ; 33 | -------------------------------------------------------------------------------- /lib/sram.aforth: -------------------------------------------------------------------------------- 1 | ( SRAM Control Cluster 2 | ( AP003 http://www.greenarraychips.com/home/documents/greg/AP003-110810-SRAM.pdf ) 3 | 4 | ( sram driver nodes 7, 8, 9 5 | 6 | ( ( block 270: 7 | ( node 9 suspends while waiting for a16. it uses 8 | ( the two lower page bits to output an 18-bit address. 9 | ( 10 | ( a16 xx.aaaa.aaaa.aaaa.aaaa 11 | ( p04 00.0000.0000.0000.pppp 12 | ( a18 aa.aaaa.aaaa.aaaa.aapp 13 | ( 14 | ( the code is written to minimize/equalize the time 15 | ( to output the address, which must be stable 16 | ( when node8 stores the 'start' command ) 17 | 18 | node 9 ( sram.16 address-bus ) 19 | org 0x20 20 | : main 21 | : start west ( right) b! .. data a! .. 0x3 ( mask) 22 | : cmd ( m) @b ( a16) 2* 2* over @b -if 23 | - ( p04) and or ( a18) ! cmd ; 24 | then ( p04) and or .. ( a18) ! cmd ; 25 | 26 | 27 | 28 | ( ( block 272: 29 | ( node8 is fed a stop command during start-up, then 30 | ( suspends while waiting for a16. after starting 31 | ( the read or write, it again suspends while 32 | ( waiting for the stop command. 33 | ( 34 | ( bits 4..2 of the /possibly inverted/ page value 35 | ( are used 'as-is' to index into the start table, 36 | ( setting two address bits, write enable, and chip 37 | ( enable. ** note that reads and writes are swapped 38 | ( if the page 'overflows' into bit4, with 39 | ( disastrous results ** 40 | ( 41 | ( cmd index .lit. pin17 pin05 pin03 pin01 42 | ( w00 .0111 2556A a19-0 a18-0 /we-0 /ce-0 43 | ( r00 .0000 2556E a19-0 a18-0 /we-1 /ce-0 44 | ( w01 .0110 2557A a19-0 a18-1 /we-0 /ce-0 45 | ( r01 .0001 2557E a19-0 a18-1 /we-1 /ce-0 46 | ( w10 .0101 3556A a19-1 a18-0 /we-0 /ce-0 47 | ( r10 .0010 3556E a19-1 a18-0 /we-1 /ce-0 48 | ( w11 .0100 3557A a19-1 a18-1 /we-0 /ce-0 49 | ( r11 .0011 3557E a19-1 a18-1 /we-1 /ce-0 ) 50 | ( 51 | node 8 ( control-pins ) 52 | org 0 53 | :: 'r-l- 0x1F5 lit ; ( TODO: why? 54 | ( 'start' pin control table 0-7) 55 | , 0x2556E ( r00) , 0x2557E ( r01) 56 | , 0x3556E ( r10) , 0x3557E ( r11) 57 | , 0x3557A ( w11) , 0x3556A ( w10) 58 | , 0x2557A ( w01) , 0x2556A ( w00) 59 | org 0x20 60 | 61 | : main 62 | : start 'r-l- b! io a! 63 | : cmd @b ( stop) ! a push 0x7 ( mask) .. 64 | @b ( a16) !b @b ( +p/-p) dup !b 65 | 2/ 2/ and ( i3) a! .. @ ( ctrl) pop a! 66 | ( start) ! cmd ; 67 | 68 | 69 | 70 | ( ( block 274: 71 | ( node7 suspends waiting for a16, passes it and 72 | ( page/r/w to nodes 8 and 9, finally controlling 73 | ( the data transfer and timing until sending the 74 | ( stop command. 75 | ( 76 | ( the literals needed for writing are loaded 77 | ( onto the stack and used circularly to save 78 | ( time. /read's drops are free./ 79 | ( 80 | ( ---- .lit. pin17 pin05 pin03 pin01 81 | ( stop 3557F a19-1 a18-1 /we-1 /ce-1 ) 82 | 83 | node 7 ( data-bus) 84 | org 0x20 85 | :: in 0x14555 lit ; 86 | :: out 0x15555 lit ; 87 | :: stop 0x3557F lit ; 88 | 89 | : main 90 | : start east ( left) b! out io data stop 91 | out io data stop in io a! ( in) ! 92 | north ( down) a! ( stop) !b 93 | : cmd ( /soid/) @ ( a16 ) !b @ ( +p/-p ) -if 94 | 95 | : w16 ( /soid/p-) ( +p/-p) !b 96 | ( /- setup + 45ns) @ ( w) a push push ( data) a! 97 | pop ! ( io) a! ( out) ! ( 40) 13 for unext ( stop) !b 98 | ( -/) in ! pop a! cmd ; 99 | 100 | : r16 ( /soid/p-) then ( +p/-p) !b 101 | ( /- setup + 55ns) a push ( data) a! 102 | ( io) drop ( out) drop ( 50) 40 for unext ( stop) !b ( -/ ) 103 | @ ( w) pop a! ! cmd ; 104 | -------------------------------------------------------------------------------- /make-ga-script.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | FILE=ga 4 | SIMFILE=ga-sim 5 | 6 | echo "#!/bin/bash" > $FILE 7 | echo "# !!! auto generated by make-ga-script.sh !!!" >> $FILE 8 | echo "emacs --quick --script $(pwd)/src/ga-main.el" '--wd $(pwd) $@' >> $FILE 9 | 10 | echo "#!/bin/bash" > $SIMFILE 11 | echo "# !!! auto generated by make-ga-script.sh !!!" >> $SIMFILE 12 | echo "emacs --no-init-file --quick --no-site-lisp --background-color gray14 --no-bitmap-icon --load $(pwd)/src/ga-run-simulator.el" ' $(pwd) $@' >> $SIMFILE 13 | 14 | -------------------------------------------------------------------------------- /readme.org: -------------------------------------------------------------------------------- 1 | 2 | *The new version of these tools is located here:* [[https://github.com/mschuldt/ga-tools][https://github.com/mschuldt/ga-tools]] \\ 3 | *This repo will no longer be maintained.* 4 | 5 | 6 | An alternative Arrayforth toolchain targeting the GA144 multi-processor chip. 7 | 8 | It includes a compiler, loader, and simulator. All independent of the Greenarrays tools. 9 | 10 | Supports the colorforth [[https://mschuldt.github.io/www.colorforth.com/inst.htm][instruction set]] 11 | 12 | [[https://github.com/mschuldt/www.colorforth.com][colorforth documentation]] can be used as reference but there are some [[#heading_comparison_to_greenarrays_arrayforth][differences]] and many extensions. 13 | 14 | These tools are compatible with [[https://github.com/mangpo/chlorophyll][chlorophyll]] generated arrayforth and have some compatibility with James Bowman's [[https://github.com/jamesbowman/ga144tools][ga144tools]] 15 | 16 | * Setup 17 | ** Requirements: 18 | - Emacs 19 | - Python, pyserial 20 | - Linux (only tested on Ubuntu) 21 | ** Compiling + installation 22 | 23 | =make= to byte compile 24 | 25 | =make install= to install the =ga= and =ga-load= commands 26 | 27 | The installed =ga= script points to the source directory so that files may be edited without having to re-install. 28 | Byte compilation must be done for performance. 29 | 30 | ** Emacs setup 31 | In your emacs config: 32 | #+BEGIN_SRC emacs-lisp 33 | (add-to-list 'load-path "PATH/TO/ga144/src") 34 | (require 'ga-loadup) 35 | (ga-loadup) 36 | #+END_SRC 37 | ** Testing 38 | =ga --test= runs compiler tests. 39 | 40 | =ga --test-all= includes simulator tests (but is much slower). 41 | * First program 42 | To check that everything works, first connect the GA144 eval board or chip. 43 | Run =dmesg= to find the serial port it is connected on. 44 | Try running the lucas series example program: 45 | #+BEGIN_SRC bash 46 | ga-load examples/lucas-series.aforth /dev/ttyUSB3 460800 47 | #+END_SRC 48 | Replace =/dev/ttyUSB3= with the correct serial port. 49 | This should print out the first 15 numbers of the [[https://en.wikipedia.org/wiki/Lucas_number][lucas series]] before exiting 50 | 51 | * Compiling and Loading 52 | 53 | The command =ga-load= is used to compile and load code into the GA144. 54 | After loading it enters into a listen mode and will print words the GA144 55 | sends back over the serial port. 56 | 57 | : ga-load filename.aforth /dev/ttyUSB baud-rate 58 | 59 | is the serial port number. On Linux this can be found by running 'dmesg' after inserting the port. 60 | baud-rate defaults to 460800 61 | 62 | ** bootstream types 63 | 64 | The option ~--bootstream-type~ is used to indicate the bootstream type. 65 | 66 | Three types of bootstreams are supported 'async', '2wire', and 'async-target'. 67 | 68 | 'async' - load through node 708 serial. Default 69 | 70 | '2wire - load through node 300 2wire interface 71 | 72 | 'async-target' - Used to load code into the target chip through the host chip. 73 | code is streamed into the the host through node 705 and from the host to the 74 | target via the node 300 2wire connection. 75 | 76 | * Dumping compilation data 77 | 78 | Data from various compilation stages can be dumped for inspection or as input to other programs. 79 | Output format defaults to json. 80 | 81 | : ga [options] file.aforth 82 | 83 | related options: 84 | | -p | pretty print the compiled data | 85 | | -n | Only print data for a given node | 86 | | -b | include the bootstream | 87 | | -s | include the symbol table | 88 | | -h | print help | 89 | 90 | * Simulation 91 | 92 | The =--sim= option runs the visual simulator: 93 | : ga --sim FILE.aforth 94 | 95 | The currently selected node is highlighted in green 96 | 97 | ** non-interactive simulation 98 | To run an aforth program at the cli: 99 | : ga --run FILE.aforth 100 | 101 | Values can be printed from the simulation using the support for [[#heading_lisp_function_calls][lisp functions]] like ~!!printT~ 102 | 103 | Simulation exits when all nodes are suspended. 104 | ** lisp simulations 105 | The most simulation options are available when setup from elisp. 106 | 107 | To run elisp simulation files: 108 | : ga FILE.el 109 | 110 | =examples/probe-demo.el= is an example of a program intended to be run like this. 111 | 112 | ** breakpoints 113 | Set a breakpoint at a word: 114 | #+BEGIN_SRC emacs-lisp 115 | (setq host (ga144-new "host")) 116 | (send host load assembled) ;; code must be loaded before breakpoints can be set 117 | (setq node (ga144-get-node host 705)) 118 | (send node set-breakpoint "word") 119 | (send node set-breakpoint 12) 120 | #+END_SRC 121 | 122 | see =tests/ga-test-pins.el= for an example using ~set-breakpoint~ 123 | 124 | *** aforth source breakpoints with !!break 125 | In aforth source use ~!!break~ to mark a location to trigger a breakpoint at. 126 | This will trigger a breakpoint immediately after that instruction as executed, 127 | If you want to trigger a breakpoint after a call to a word has returned 128 | like ~word !!break~ then you must insert a nop ~word . !!break~ before the 129 | break or move the !!break forward one instruction. This is because the breakpoint 130 | triggers after the call instruction executes (pushing P to the return stack and setting new P), 131 | not after the word returns to the current context. 132 | 133 | ** simulation control 134 | keys: 135 | | s | Step the selected one by the current step increment (default 1) | 136 | | S | Like 's' but steps all nodes | 137 | | c | Continue stepping until quit 'g' or all nodes are suspended | 138 | | n | Set the step increment used by 's' | 139 | | u | usage view (default) | 140 | | a | activity view | 141 | | + | incrase map size | 142 | | - | decrease map size | 143 | | p | enable source-level debug mode | 144 | TODO: other keys 145 | ** simulating bootstreams 146 | TODO: 147 | not about but in node 708 148 | (activity in this node is not too important as serial protocol is not being simulated, instead it is loaded a simulated port) 149 | 150 | ** ROM 151 | The rom loaded in the simulator is dumped from a ga144 152 | TODO: how to update it 153 | 154 | ** testbed support 155 | GPIO pins values can be set with ~set-pin!~ 156 | Functions that to react to pin changes are set with ~set-gpio-handler~ 157 | 158 | #+BEGIN_SRC emacs-lisp 159 | (send node300 set-gpio-handler 0 (lambda (x) (message "node 300.17 changed to: %s" x))) 160 | #+END_SRC 161 | 162 | ~set-gpio-handlers~ can be used to set all the pin handlers at once: 163 | #+BEGIN_SRC emacs-lisp 164 | (send host-node set-gpio-handlers pin1Callback pin2Callback ...) 165 | #+END_SRC 166 | 167 | Example: =tests/ga-test-pins.el= 168 | 169 | There is currently only support for a one pin handler per pin. 170 | Connecting multiple handlers with ~ga-connect-pins~ or ~set-gpio-handlers~ 171 | will overwrite exiting handlers. 172 | 173 | No support for setting analog pin values. 174 | 175 | [[#heading_lisp_function_calls][lisp functions]] can be created to produce side effects to mimic the presence of other forth functionality 176 | in the interior of the chip. This can be useful for testing components in isolation or simulating 177 | access to complicated external functionality faster then through the GPIO interface. 178 | 179 | ** Connecting pins 180 | 181 | Virtually connect pins of separate GA144 instances: 182 | #+BEGIN_SRC emacs-lisp 183 | (setq host (ga144-new "host")) 184 | (setq target (ga144-new "target")) 185 | (ga-connect-pins (ga144-get-node host 300) 0 186 | (ga-get-node target 300) 0) 187 | (ga-connect-pins (ga144-get-node host 300) 1 188 | (ga-get-node target 300) 1) 189 | #+END_SRC 190 | 191 | ~ga-connect-pins~ is a convenience wrapper around ~set-gpio-handler~ and ~set-pin!~ 192 | 193 | Example: =tests/ga-test-target-chip.el= 194 | ** Simulating bootstream 195 | When the option =--sim-bootstream= is used the full bootstream loading will be simulated instead of 196 | starting the simulation with the code pre-loaded in all the nodes. This is very slow and usually undesirable. 197 | 198 | : ga --sim --sim-bootstream FILE.aforth 199 | 200 | The only supported bootstream in simulation is through node 708. 201 | 202 | ** Virtual digital analyzer 203 | Virtual probes can be connected to GPIO pins to record their state over time. 204 | 205 | ~ga-connect-probe~ attaches a probe to a node's pin. ~ga144-probe-save~ generates 206 | A python program (which depends on matplotlib), 207 | running it will display the graphed pin activity of all instrumented pins. 208 | 209 | #+BEGIN_SRC emacs-lisp 210 | (setq chip (ga144-new "host")) 211 | (setq node705 (send chip coord->node 705)) 212 | (ga-connect-probe node705 0) 213 | (ga144-probe-save) 214 | #+END_SRC 215 | 216 | Runnable example: =ga examples/probe-demo.el= 217 | 218 | ** Lisp function calls 219 | :PROPERTIES: 220 | :CUSTOM_ID: heading_lisp_function_calls 221 | :END: 222 | 223 | Functions defined in lisp may be called from the arrayforth program with the syntax ~!!FUNCTION~ 224 | These functions must be defined with the ~(ga-define NAME BODY...)~ macro. 225 | 226 | An example function that prints the dstack: 227 | #+BEGIN_SRC elisp 228 | (ga-define printDstack 229 | (princ (format "%s\n" (send node get-dstack-as-list)))) 230 | #+END_SRC 231 | This can then be called in the aforth program with ~!!printDstack~ 232 | The node that it is called from is bound to the variable =node= 233 | 234 | It will be called after the execution of the instruction that precedes it. 235 | 236 | Lisp files that define these functions are loaded into arrayforth with the =include= directive: 237 | 238 | : include FILENAME.el 239 | 240 | Built in words include ~!!printT~ and ~!!break~, they are defined in =src/ga144-sim.el= 241 | 242 | Example programs that use these features: =example/test-print.el=, =example/test-print.aforth=, 243 | and =example/test-print2.aforth= 244 | 245 | ** known issues 246 | - reset with 'g' and 'b' fail to reset the chip properly, 247 | If stepping the whole chip with 'c' or 'S' restart simulation instead of reset 248 | - TODO: others? 249 | 250 | * converting colorforth forth to arrayforth 251 | 252 | The utility ref/cf2f.py converts colorFrth source to mostly legal arrayforth. 253 | It is useful for referencing colorForth sources, the entire translated colorforth source 254 | is included as ref/OkadBack.txt 255 | 256 | * boot descriptors 257 | boot descriptors are the mechanism for specifying the initial state of an f18 computer. 258 | This includes the values in the registers and on the stacks. 259 | 260 | The following boot descriptors are supported: ~/p~, ~/b~, ~/a~, ~/stack~ 261 | 262 | For example, to set the inital value of register =a= to 5 and =b= to the west port: 263 | : /a 5 /b west 264 | 265 | =/stack= takes the number of items to leave on the data stack followed by their values: 266 | : /stack 3 11 22 33 267 | 268 | * Chlorophyll compatibility 269 | 270 | This was originally built to support work with [[http://pl.eecs.berkeley.edu/projects/chlorophyll/][Chlorophyll]] and will remain useful for doing so. 271 | Any incompatibility with the output of Chlorophyll is considered a bug. 272 | 273 | * jamesbowman/ga144tools compatibility 274 | TODO 275 | * Comparison to Greenarrays arrayforth 276 | :PROPERTIES: 277 | :CUSTOM_ID: heading_comparison_to_greenarrays_arrayforth 278 | :END: 279 | 280 | This compiler differs from the Greenarrays version in several ways. 281 | Knowing the differences is helpful if you already know arrayforth or if you want to use the Greenarrays documentation. 282 | 283 | - No semantic color 284 | - standard forth syntax for words and comments 285 | - hex,bin literals: 0xN, 0bN 286 | - boot descriptors and other yellow words are reserved keywords. 287 | - ~north~, ~east~, ~south~, and ~west~ 288 | get resolved to correct ports, ~up~, ~down~, ~left~, or ~right~ 289 | - Each node has a seporate namespace 290 | - word@coord compiles a call to =word= in node =coord=. 291 | - The word ~reclaim~ has no use. 292 | - Automatic nop insertion. 293 | - Can be disabled. 294 | - Currently inserts nops even when not actually needed 295 | - Arguments follow the yellow words. 296 | For example, use ~'node 715'~ instead of ~'715 node'~. 297 | - Generalized host computations during compilation are not supported. 298 | The compiler is not a forth interpreter. 299 | - There are no grey words 300 | - Automatically shift words when destination address does not fit in word. 301 | arrayforth does not compile in such situations, manual word alignment is necessary 302 | - words may be called before their definition 303 | - All comments are terminated by newlines 304 | - Use ~swap!~ instead of ~swap~ 305 | 306 | * references 307 | 308 | Useful links from colorforth.com for programming the ga144: 309 | https://github.com/mschuldt/www.colorforth.com 310 | 311 | * extended instructions 312 | ~next:~, ~-if:~ 313 | 314 | Used when converting .ga files to .aforth or when optimizing code. 315 | Also when translating from bowman mode, need to use ~begin~ for each corresponding ~unext~ 316 | 317 | TODO: document 318 | * list of unsupported simulation features 319 | - analog pins 320 | - phantom wakeups 321 | - shared pins? 322 | TODO: anything else? 323 | * source-level debuging 324 | * Limitations, known problems 325 | TODO 326 | 327 | sometimes line numbers reported in error messages are wrong 328 | 329 | ~org~ can only be used at the beginning of a node, before all instructions. Using it after instructions can result in a compile error 330 | line numbers in errors for undefined words are wrong 331 | 332 | make does not aboart when there is a compilation error. must search the output for 'Error:' 333 | 334 | The =--run= option does not print anything if their is a compilation error, it just exists. 335 | best to check with ga =-p= or =-c= before trying to run or simulate 336 | 337 | simulation is broken after reset. (nodes suspended nodes in the active list) 338 | This also means that the load from bootstream option is broken because 339 | 340 | 341 | crash when loading bootstream in simulator with node 708 selected. 342 | 343 | chlorophyll compatibility problems 344 | in simulation can't return from main with ';' do nothing for call warm. this results in invalid port read error 345 | 346 | simulator gets stuck entering debugger sometimes 347 | when this happens it's possible to run the program with the =--run= option in instead of =--sim= to view the error. 348 | 349 | 350 | No support for setting analog pin values in simulator 351 | 352 | bug: word@node forms can only reference words in nodes that have already been defined 353 | 354 | problem with !!words, getting set in the wrong location, so sometimes breakpoints dont work. 355 | if there is space in the node one workaround is to define a word in low memory that contains the 356 | beakpoint or call to other !!word that call that when needed. 357 | -------------------------------------------------------------------------------- /ref/OkadBack.cf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mschuldt/ga144/5b327b958f5d35cf5a015044e6ee62f46446169f/ref/OkadBack.cf -------------------------------------------------------------------------------- /ref/cf2f.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/python 2 | 3 | # based on: https://github.com/mangpo/chlorophyll/blob/master/cforth_tools/cf2f.py 4 | # Modified to output in .aforth format 5 | 6 | '''\ 7 | simple colorforth to forth translator 8 | 9 | see Charley Shattuck's post for the general idea: 10 | http://www.strangegizmo.com/forth/ColorForth/msg00209.html 11 | in addition, we will use [compile] in front of cyan words 12 | 13 | also, we will use angle brackets, e.g. < macro >, around words defined in the 14 | kernel to mark those with no tag, otherwise words outside of definitions 15 | are assumed to be yellow (executed). 16 | 17 | markup_ functions are helpers, to "mark up" the bare words with 18 | indicators as to their "color", i.e. syntax, in those cases where positional 19 | or other clues are insufficient. 20 | ''' 21 | import sys, os, struct, re 22 | try: 23 | from cfword import * 24 | except: # this should work with pytest 25 | sys.path.append('.') 26 | import cfword 27 | from cfword import * 28 | # http://colorforth.com/parsed.html 29 | # => https://mschuldt.github.io/www.colorforth.com/parsed.html 30 | 31 | MARKUP = { # tagname patterns to trigger markup_ 32 | 'highlevel': [ 33 | ['^compilemacro$', 'macro'], # must go before compile 34 | ['^compile', 'compile'], 35 | ['^execute', 'execute'], 36 | ['^definition$', 'definition'], # set state to 'compile' 37 | ['^text', 'text'], 38 | ['^variable$', 'variable'], 39 | ['.*word$', 'numeric'], # this check must come *after* compile and execute 40 | ['^formatting$', 'formatting'], # "blue words": cr, br, indent, etc. 41 | ['^commented', 'commented'], # new "commented number" tag 0xf 42 | ['^feedback', 'feedback'], # new "compiler feedback number" tag 0xd 43 | ], 44 | 'binary': [ 45 | ['^extension$', 'bareword'], 46 | ] 47 | } 48 | 49 | SIGNBIT = (1 << 26) 50 | MAXSHORT = SIGNBIT - 1 # 27 bits max colorforth "short" integer 51 | INT = 0xffffffff 52 | DEFAULT = ['execute'] # default action, reset at start of each block 53 | # bit 27 is the sign bit, so the above is the largest positive number 54 | 55 | block_num = 0 56 | def cf2f(infile = sys.stdin, output = sys.stdout): 57 | global block_num 58 | blocks = getbinary(infile) 59 | for index in range(18, len(blocks)): 60 | block_num = index 61 | DEFAULT[:] = ['execute'] # reset default action 62 | print >>output, '( block %d )' % index 63 | block = getwords(blocks[index]) 64 | debug('unpacking block %d' % index, 2) 65 | unpack_all(block) 66 | output_text(block, output) 67 | 68 | def output_text(block, output): 69 | for i in range(len(block)): 70 | if block[i][0] == ':' and not nocr(block, i - 1): 71 | output.softspace = False 72 | print >>output 73 | if block[i][1] != 'formatting': 74 | print >>output, block[i][0], 75 | if block[i][0] in ['cr', 'br', 'indent'] and block[i][1] == 'formatting': 76 | output.softspace = False 77 | print >>output 78 | if block[i][0] == 'br': # double newline 79 | print >>output 80 | elif block[i][0] == 'indent': 81 | print ' ', # 4 spaces plus one added by Python 82 | print >>output # end of block 83 | print >>output 84 | 85 | def nocr(block, index): 86 | return padblock(block)[index][0] == '-cr' 87 | 88 | def is_empty(block): 89 | if len(block): 90 | if type(block[0]) is list: 91 | empty = [['[0x0]', None]] * len(block) 92 | else: 93 | empty = [0] * len(block) 94 | return block == empty 95 | else: 96 | return True 97 | 98 | def unpack_number(block, index): 99 | 'unpack one- or two-word number and return updated index' 100 | tag = TAGS[block[index] & 0xf] 101 | if tag.endswith(('short', 'long')): 102 | hex = bool(block[index] & 0x10) 103 | debug('unpacking number %s, tag=%s, hex=%s' % (block[index], tag, hex), 2) 104 | block[index] >>= 5 105 | if tag.endswith('long'): 106 | if block[index] != 0 or not block[index + 1:]: 107 | block[index] = [unpack_binary(TAGS.index(tag) | (hex << 4)), None] 108 | return index + 1, True 109 | else: 110 | block.pop(index) # puts value in current slot 111 | if hex: 112 | block[index] = ['0x%x' % (sign_extend(block[index], tag) & INT), tag] 113 | else: 114 | block[index] = ['%d' % block[index], tag] 115 | return index + 1, True 116 | else: 117 | return index, False 118 | 119 | def sign_extend(number, tag): 120 | if tag.endswith('short') and number > MAXSHORT: 121 | number |= -SIGNBIT 122 | return number 123 | 124 | def unpack_all_binary(block, index = 0): 125 | 'go through raw numbers and unpack as [0xn] or untagged strings' 126 | while not is_empty(block[index:]): 127 | unpacked = unpack(block[index]) 128 | if unpacked[1] != 'extension': 129 | unpacked = [unpack_binary(block[index]), None] 130 | block[index] = unpacked 131 | index += 1 132 | block[index:] = [] 133 | markup(block, 'binary') 134 | 135 | def unpack_all(rawblock, index = 0): 136 | 'go through raw numbers and unpack into number and text strings' 137 | block = list(rawblock) # copy in case we find it's not high-level forth 138 | while not is_empty(block[index:]): 139 | if padblock(block)[index - 1][1] == 'variable': 140 | block[index] = [unpack_binary(block[index]), None] 141 | index += 1 142 | else: 143 | index, processed = unpack_number(block, index) # try as number first 144 | if not processed: 145 | block[index] = unpack(block[index]) 146 | index += 1 147 | if block[index - 1][1] == None: 148 | debug('marking binary at %s' % block[:index + 1], 2) 149 | return unpack_all_binary(rawblock, index = 0) 150 | block[index:] = [] # trim trailing zeros 151 | if not connect_extensions(block): 152 | return unpack_all_binary(rawblock, index = 0) 153 | markup(block, 'highlevel') 154 | rawblock[:] = block 155 | 156 | word_type_host = False 157 | 158 | reversed_words = [ "node", "org", "," ]#, "/b", "/a", "/io", "/p", "/stack" ] 159 | 160 | def markup(block, blocktype = 'highlevel', index = 0): 161 | '''add syntactic cues for text-mode rendition of colorforth 162 | 163 | each markup_ function will return an index and offset; 164 | the index is where the next markup_ function will act, and 165 | the offset is the number of words added beyond the index. 166 | a special offset of None will indicate to the markup loop 167 | to skip any further processing.''' 168 | global word_type_host 169 | word_type_host = False 170 | while block[index:]: 171 | item, word, tag, adjust = block[index], block[index][0], block[index][1], 0 172 | debug('marking up: %s' % item, 2) 173 | if word == "host": 174 | word_type_host = True 175 | elif word == "target": 176 | word_type_host = False 177 | elif not block_num %2 and word in reversed_words and tag == 'executeword': 178 | block[index-1], block[index] = block[index], block[index-1] 179 | 180 | for pattern in MARKUP[blocktype]: 181 | if re.compile(pattern[0]).match(tag or 'NO_MATCH'): 182 | debug('marking up as %s' % pattern[1], 2) 183 | index, offset = eval('markup_' + pattern[1])(block, index) 184 | if offset == None: 185 | break 186 | else: 187 | adjust += offset 188 | debug('adjusting index %d by %d' % (index, adjust + 1), 2) 189 | index += adjust + 1 190 | 191 | def markup_formatting(block, index): 192 | 'signify a formatting word to differentiate format cr from kernel cr' 193 | #block.insert(index, ['|', 'markup']) 194 | #return index + 1, None 195 | return index, None 196 | 197 | def markup_feedback(block, index): 198 | 'signify a "compiler feedback" number' 199 | debug('compiler feedback number: %s' % block[index], 2) 200 | block.insert(index, ['(', 'markup']) 201 | block.insert(index + 2, [')', 'markup']) 202 | return index + 2, None 203 | 204 | def markup_commented(block, index): 205 | 'signify a "commented" number rather than one compiled or executed' 206 | block.insert(index, ['(', 'markup']) 207 | block.insert(index + 2, [')', 'markup']) 208 | return index + 2, None 209 | 210 | def markup_definition(block, index): 211 | 'put colon before defined word' 212 | block.insert(index, ['::' if word_type_host else ':', 'markup']) 213 | DEFAULT[-1] = 'compile' 214 | return index + 1, None # skip over colon 215 | 216 | def markup_variable(block, index): 217 | debug('marking up variable %s' % block[index][0], 2) 218 | block.insert(index, [':var', 'markup']) 219 | index += 1 220 | if block[index + 1:] and block[index + 1][0] == '[0x0]': 221 | block.pop(index + 1) 222 | return index, None 223 | else: 224 | return index + 1, None # skip "binary" number following 225 | 226 | def markup_macro(block, index): 227 | debug('marking up macro %s' % block[index][0], 2) 228 | block.insert(index, ['[compile]', 'markup']) 229 | return index + 1, None 230 | 231 | def markup_textallcaps(block, index): 232 | assert False 233 | word, marked_up = block[index][0], block[index][0].upper() 234 | if marked_up in [word.lower(), word.capitalize()]: 235 | debug('explicitly marking %s as allcaps' % block[index], 2) 236 | block.insert(index, ['^^', 'markup']) 237 | index += 1 238 | block[index][0] = marked_up 239 | return index # note this should NOT return tuple 240 | 241 | def markup_textcapitalized(block, index): 242 | assert False 243 | word, marked_up = block[index][0], block[index][0].capitalize() 244 | debug('as is, upper, capital: %s' % [word, word.upper(), marked_up], 2) 245 | if marked_up in [word.lower(), word.upper()]: 246 | debug('explicitly marking %s as capitalized' % block[index], 2) 247 | block.insert(index, ['^', 'markup']) 248 | index += 1 249 | block[index][0] = marked_up 250 | return index # note this should NOT return tuple 251 | 252 | def markup_text(block, index): 253 | debug('marking up text %s' % block[index][0], 2) 254 | block.insert(index, ['(', 'markup']) 255 | index += 1 256 | while block[index:] and block[index][1].startswith('text'): 257 | if block[index][1] == 'textallcaps': 258 | index = markup_textallcaps(block, index) 259 | elif block[index][1] == 'textcapitalized': 260 | index = markup_textcapitalized(block, index) 261 | index += 1 262 | block[index - 1][0] += ')' 263 | return index - 1, None # point to last commented word 264 | 265 | def markup_execute(block, index): 266 | if DEFAULT[-1] == 'compile': 267 | debug('switching default to "execute" at %s' % end(block, index), 2) 268 | block.insert(index, ['', 'markup']) 269 | DEFAULT[-1] = 'execute' 270 | index += 1 271 | return index, 0 272 | elif padblock(block)[index + 1][1] == 'definition': 273 | block.insert(index + 1, ['', 'markup']) 274 | DEFAULT[-1] = 'compile' 275 | return index, 1 276 | else: 277 | return index, 0 278 | 279 | def end(block, index): 280 | 'end of current part of block, for debugging' 281 | return block[max(0, index - 9):index + 1] 282 | 283 | def markup_compile(block, index): 284 | if DEFAULT[-1] == 'execute': 285 | debug('switching default to "compile" at %s' % end(block, index), 2) 286 | block.insert(index, ['', 'markup']) 287 | DEFAULT[-1] = 'compile' 288 | index += 1 289 | if block[index][0] == ';': 290 | debug('switching default to "execute" at %s' % end(block, index), 2) 291 | DEFAULT[-1] = 'execute' 292 | return index, 0 293 | 294 | def padblock(block): 295 | 'pad so that block[i-1] or block[i+1] will always see [[None, None]] at end' 296 | return block + [[None, None]] 297 | 298 | def connect_extensions(block, index = 0, ok = True): 299 | '''join extension[s] to previous word 300 | 301 | due to binary value following a variable declaration (magenta word), 302 | a variable name cannot have an extension. otherwise how could 303 | colorforth know whether it were an extension or the value?''' 304 | debug('connecting extensions in block: %s' % block, 2) 305 | while block[index:]: 306 | tag = block[index][1] 307 | if tag == 'extension': 308 | debug('found bad tag at: %s' % end(block, index), 2) 309 | ok = False 310 | break 311 | elif tag is None or tag.endswith(('variable', 'short', 'long')): 312 | index += 1 # none of these can have extensions 313 | continue 314 | while padblock(block)[index + 1][1] == 'extension': 315 | block[index][0] += block.pop(index + 1)[0] 316 | index += 1 317 | return ok 318 | 319 | def is_decimal(string): 320 | 'determine if string represents a decimal number' 321 | return re.compile('^-?[0-9]+$').match(string) 322 | 323 | def markup_numeric(block, index): 324 | 'mark a word that looks like a number' 325 | if is_decimal(block[index][0]) and block[index][1].endswith('word'): 326 | debug('marking up "%s" as numeric-looking word' % block[index], 2) 327 | block.insert(index, ['$', 'markup']) 328 | return index + 1, None 329 | else: 330 | debug('skipping markup of "%s" to number' % block[index], 2) 331 | return index, 0 332 | 333 | def markup_bareword(block, index): 334 | block.insert(index, ['<', 'markup']) 335 | index += 1 336 | while block[index:] and block[index][1] == 'extension': 337 | index += 1 338 | block.insert(index, ['>', 'markup']) 339 | return index + 1, None 340 | 341 | def getbinary(filename, data = ''): 342 | 'concatenate block data from files or stdin' 343 | if type(filename) == str: 344 | input = open(filename, 'rb') 345 | else: 346 | input = filename 347 | data += input.read() 348 | input.close() 349 | if not data: 350 | data = sys.stdin.read() 351 | blocks = [data[n:n + 1024] for n in range(0, len(data), 1024)] 352 | return blocks 353 | 354 | def getwords(block): 355 | words = list(struct.unpack('<%dl' % (len(block) / 4), block)) 356 | return words 357 | 358 | if __name__ == '__main__': 359 | print "( -*- mode: aforth -*- )" 360 | cf2f( *sys.argv[1:] ) 361 | -------------------------------------------------------------------------------- /ref/cfword.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/python 2 | """\ 3 | huffman-encode and decode colorforth words 4 | 5 | The 4-bit letters begin with zero, and have a value exactly the same as 6 | their offset in the translation table. 5-bit letters begin with a one, and 7 | are the second set of 8 characters in the table, and so begin with the 8 | value 16, or 8 plus their offset. 7-bit letters, the remainder, all begin 9 | with binary 11, and start at offset 16; 0b1100000 is decimal 96, so one 10 | needs to add 80 to the offset to create the 7-bit value. 11 | 12 | See http://colorforth.com/chars.html, and updates in DB004 arrayForth 13 | User's Manual, p. 42, from GreenArrays.com. 14 | """ 15 | import sys, os, struct, re 16 | # the old huffman code is from http://www.colorforth.com/chars.html 17 | OLDCODE = ' rtoeani' + 'smcylgfw' + 'dvpbhxuq' + 'kzj34567' + \ 18 | '891-0.2/' + ';:!+@*,?' 19 | # new Huffman encoding from Tim Neitz 20 | NEWCODE = ' rtoeani' + 'smcylgfw' + 'dvpbhxuq' + '01234567' + \ 21 | '89j-k.z/' + ";'!+@*,?" 22 | CODE = NEWCODE # assume Tim knows what he's doing 23 | CODEDICT = dict([[c + (8 * (8 <= c < 16)) + (80 * (c >= 16)), CODE[c]] 24 | for c in range(len(CODE))]) 25 | HIGHBIT = 0x80000000L 26 | MASK = 0xffffffffL 27 | TRAILING_ZEROS = dict([[1 << n, n] for n in range(32)]) 28 | FUNCTIONS = [ #from tag in low 4 bits of each compressed 32-bit word 29 | # 'yellow' and 'green' become 'brown' and 'pine' if hexadecimal; 30 | # bit 4 of the word is 1 if it should be rendered as hex 31 | ['extension', 'white'], # 0 32 | ['executeword', 'yellow'], 33 | ['executelong', 'yellow'], 34 | ['definition', 'red'], 35 | ['compileword', 'green'], # 4 36 | ['compilelong', 'green'], 37 | ['compileshort', 'green'], 38 | ['compilemacro', 'cyan'], 39 | ['executeshort', 'yellow'], # 8 40 | ['textnocaps', 'white'], 41 | ['textcapitalized', 'white'], 42 | ['textallcaps', 'white'], 43 | ['variable', 'magenta'], # 12 44 | ['feedbackshort', 'silver'], 45 | ['formatting', 'blue'], 46 | ['commentedshort', 'white'] 47 | ] 48 | TAGS = [function[0] for function in FUNCTIONS] 49 | COLORS = [function[1] for function in FUNCTIONS] 50 | DEBUGLEVEL = int(os.getenv('DEBUGLEVEL') or '-1') 51 | def bits_unused(letter): 52 | """28 bits are available for compressing text 53 | 54 | but only 1-bits count; if a letter ends in zeroes, as does "@" 55 | with an encoding of 0b1111100, only 5 bits are deemed to have 56 | been used, so this should return 2 for the 2 unused bits.""" 57 | if letter is None: return 0 # in case word was 0, lettercode undefined 58 | first_one_bit = letter & -letter # Gosper's hack 59 | return TRAILING_ZEROS[first_one_bit] 60 | def unpack_binary(coded): 61 | 'return untagged number' 62 | return '[0x%x]' % (coded & 0xffffffff) 63 | def pack_binary(string): 64 | 'return raw binary number' 65 | return eval(string)[0] 66 | def unpack(coded): 67 | 'show packed number as text' 68 | text, bits, tag = '', 32 - 4, TAGS[coded & 0xf] # low 4 bits are the tag 69 | # now get rid of sign bit and remove the tag from the number 70 | # this only works because coded is a long 71 | number, lettercode = coded & 0xfffffff0, None 72 | while number: 73 | lettercode, codebits, number = number >> 28, 4, (number << 4) & MASK 74 | fivebits = bool(lettercode & 8) # at least 5 bits if high bit set 75 | sevenbits = fivebits and bool(lettercode & 4) # 7 bits if top two bits set 76 | for iteration in range(fivebits + sevenbits + sevenbits): 77 | lettercode = (lettercode << 1) | bool(number & HIGHBIT) 78 | number = (number << 1) & MASK 79 | codebits += 1 80 | text, bits = text + CODEDICT[lettercode], bits - codebits 81 | if ' ' in text or bits + bits_unused(lettercode) < 0 or not len(text): 82 | debug('Cannot unpack, bits remaining: %d, text: "%s"' % (bits, text), 2) 83 | return [unpack_binary(coded), None] # it wasn't a valid word 84 | elif tag.endswith(('short', 'long')): 85 | return [unpack_binary(coded), None] 86 | else: 87 | return [text, tag] 88 | def pack(word): 89 | 'pack text into number' 90 | word, packed, bits, unused, unpacked = word.lower(), 0, 28, 0, '' 91 | debug('packing "%s"' % word, 2) 92 | for index in range(len(word)): 93 | letter = word[index] 94 | lettercode = CODE.index(letter) 95 | length = 4 + (lettercode > 7) + (2 * (lettercode > 15)) 96 | lettercode += (8 * (length == 5)) + (80 * (length == 7)) 97 | unused = bits_unused(lettercode) 98 | debug(('0x%x' % packed, '0x%x' % lettercode, bits, length - unused), 2) 99 | if length - unused > bits: 100 | unpacked = word[index:] 101 | debug('cannot pack "%s", returning packed "%s"' % (word, word[:index]), 2) 102 | break 103 | else: 104 | packed, bits = (packed << length) | lettercode, bits - length 105 | if bits < 0: 106 | packed, bits = packed >> -bits, 0 107 | packed <<= (bits + 4) 108 | return [packed, unpacked] 109 | def debug(message, debuglevel = 0, duplicate = None): 110 | if DEBUGLEVEL >= debuglevel: 111 | print >>sys.stderr, message 112 | if duplicate: 113 | print >>duplicate, message 114 | if __name__ == '__main__': 115 | for word in sys.argv[1:]: 116 | if word.startswith('0x'): 117 | print unpack(int(word, 16))[0], 118 | else: 119 | print '0x%x' % pack(word)[0], 120 | print 121 | -------------------------------------------------------------------------------- /src/aforth-compile.el: -------------------------------------------------------------------------------- 1 | ;; -*- lexical-binding: t -*- 2 | 3 | ;; elisp aforth-compiler entrance 4 | 5 | (require 'rkt) 6 | (require 'aforth-parse) 7 | 8 | (rkt-require "compile.rkt") ; 9 | (rkt-require "bootstream.rkt") 10 | 11 | (setq bowman-format nil) 12 | 13 | (defun aforth-compile-buffer (&optional buffer) 14 | (with-current-buffer (or buffer (current-buffer)) 15 | ;;(and buffer-file-name (save-buffer)) 16 | (if (and buffer-file-name 17 | (string= (file-name-extension buffer-file-name) "ga")) 18 | (let ((expanded (shell-command-to-string (concat "m4 " buffer-file-name)))) 19 | (with-temp-buffer 20 | (insert expanded) 21 | (convert-bowman-to-aforth) 22 | (aforth-compile-aforth-buffer))) 23 | (aforth-compile-aforth-buffer)))) 24 | 25 | (defun aforth-compile-aforth-buffer () 26 | ;; compile the current buffer 27 | (when DEBUG? (printf "DEBUG PRINT MODE\n")) 28 | (save-excursion 29 | (let (parsed-nodes ret locations) 30 | (reset!) 31 | (catch 'aforth-error 32 | (setq parsed-nodes (aforth-parse-nodes (point-min) (point-max) nil 'no-comments)) 33 | (setq aforth-compile-stage "compiling") 34 | (dolist (node parsed-nodes) 35 | (setq aforth-current-node (aforth-node-coord node)) 36 | (push (cons aforth-current-node (aforth-node-location node)) 37 | locations) 38 | (start-new-node aforth-current-node) 39 | (setq current-token-list (aforth-node-code node)) 40 | 41 | (while current-token-list 42 | (setq aforth-current-token (read-tok)) 43 | (compile-token aforth-current-token))) 44 | (when memory 45 | (fill-rest-with-nops) ;;make sure last instruction is full 46 | (set-current-node-length)) 47 | (when current-node 48 | (set-node-address-cells! current-node address-cells)) 49 | 50 | (when DEBUG? (display-compiled (compiled used-nodes nil))) 51 | 52 | ;; errors from this point on are not associated with line numbers 53 | (setq current-tok-line nil 54 | current-tok-col nil) 55 | 56 | (setq aforth-compile-stage "checking") 57 | (mapc 'check-for-undefined-words used-nodes) 58 | 59 | (setq aforth-compile-stage "finalizing") 60 | (setq used-nodes (mapcar 'remove-address-cells used-nodes)) 61 | ;;(setq used-nodes (mapcar 'aforth-trim-memory used-nodes)) 62 | (setq ret (compiled used-nodes nil locations))) 63 | 64 | (or ret 65 | (compiled nil (aforth-get-error-data)))))) 66 | 67 | (defun aforth-compile (code) ;;shadows racket version 68 | (setq aforth-compile-input-type 'string) 69 | (with-temp-buffer 70 | (insert code) 71 | (aforth-compile-buffer))) 72 | 73 | (setq _last-read-tok nil) 74 | 75 | (defun read-tok () 76 | (when current-token-list 77 | (let ((token (car current-token-list)) 78 | token-type) 79 | (set! current-token-list (cdr current-token-list)) 80 | (when token 81 | (setq prev-current-tok-line current-tok-line 82 | prev-current-tok-col current-tok-col 83 | current-tok-line (aforth-token-start token) ;;TODO: line/col instead of buffer positions 84 | current-tok-col (aforth-token-end token))) 85 | (setq _last-read-tok token) 86 | token))) 87 | 88 | (defun unread-last-tok () 89 | (assert elisp?) 90 | (when _last-read-tok 91 | (setq current-token-list (cons _last-read-tok current-token-list)))) 92 | 93 | (defun read-tok-name () 94 | (let ((tok (read-tok))) 95 | (and tok (aforth-token-value tok)))) 96 | 97 | ;;(fset 'rkt-compile-token 'compile-token) 98 | 99 | (defun compile-token (token) 100 | (let ((token-type (aforth-token-type token)) 101 | (token-val (aforth-token-value token)) 102 | (token-args (aforth-token-args token)) 103 | func) 104 | (setq current-token-buffer-position (list (aforth-token-file token) 105 | (aforth-token-start token) 106 | (aforth-token-end token))) 107 | (setq current-token token) 108 | (cond ((or (eq token-type 'word-def) 109 | (eq token-type 'compile-def)) 110 | (setq func (get-directive token-type)) 111 | (unless func 112 | (err (format "Expected directive for: '%s, token=%s'\n" token-type token))) 113 | (funcall func token-val)) 114 | 115 | ((or (eq token-type 'directive) 116 | (eq token-type 'boot-descriptor)) 117 | (setq func (get-directive token-val)) 118 | (unless func 119 | (err (format "Expected directive for: '%s, token=%s'\n" token-val token))) 120 | (unless (listp token-args) 121 | (setq token-args (list token-args))) 122 | (apply func token-args)) 123 | 124 | ((or (setq func (get-directive token-type)) 125 | (and (eq token-type 'op) 126 | (setq func (get-directive token-val)))) 127 | (funcall func)) 128 | 129 | ((eq token-type 'op) 130 | (compile-instruction! token-val)) 131 | 132 | ((eq token-type 'number) 133 | (compile-constant! token-val)) 134 | 135 | ((eq token-type 'r-call) 136 | (compile-remote-call! token-val token-args)) 137 | 138 | ((eq token-type 'r-reference) 139 | (compile-remote-word-ref! token-val token-args)) 140 | 141 | ((eq token-type 'reference) 142 | (compile-word-ref! token-val)) 143 | 144 | ((eq token-type 'call) 145 | (compile-call! token-val)) 146 | 147 | ((eq token-type 'funcall) 148 | (compile-funcall! token-val)) 149 | 150 | (t (error "unrecognized token type: %s" token))) 151 | (setq current-token-buffer-position nil) 152 | (setq current-token nil))) 153 | 154 | (defun aforth-compile-file (filename) 155 | (setq aforth-compile-input-type 'file) 156 | (with-temp-buffer 157 | (if (string= (file-name-extension in-file) "ga") 158 | (open-file-from-bowman-format filename) 159 | (insert-file-contents-literally filename)) 160 | (setq buffer-file-name filename) 161 | (aforth-compile-buffer))) 162 | 163 | (defun open-file-from-bowman-format (filename) 164 | (setq bowman-format t) 165 | (setq filename (expand-file-name filename)) 166 | (insert (shell-command-to-string (concat "m4 " filename))) 167 | (convert-bowman-to-aforth) 168 | ;;(write-file (concat filename ".aforth")) 169 | ) 170 | 171 | (defun convert-bowman-to-aforth () 172 | (goto-char 1) 173 | (while (re-search-forward "^ *-+ \\([0-9]+\\) -+ *$" nil t) 174 | (replace-match (format "node %s" (match-string 1)))) 175 | 176 | (dolist (d '("NORTH" "SOUTH" "EAST" "WEST")) 177 | (goto-char 1) 178 | (while (re-search-forward d nil t) 179 | (replace-match (downcase d) t)))) 180 | 181 | (defmacro compiler-binop(op) 182 | `(push (funcall ',op (pop stack) (pop stack)) stack)) 183 | 184 | (defun aforth-trim-memory (node) 185 | (let ((mem (vector->list (nreverse (node-mem node))))) 186 | (while (equal (car mem) [nil nil nil nil]) 187 | (setq mem (cdr mem))) 188 | (set-node-mem! node (list->vector (nreverse mem))) 189 | node)) 190 | 191 | (defun compile-file-to-bootstream (file bootstream-type) 192 | (let* ((compiled (aforth-compile-file file)) 193 | (assembled (assemble compiled)) 194 | (bootstream (make-bootstream assembled bootstream-type))) 195 | (sget-convert bootstream))) 196 | 197 | (defun aforth-parse-string (str &optional no-comments) 198 | (with-temp-buffer 199 | (insert str) 200 | (aforth-parse-nodes (point-min) (point-max) nil no-comments))) 201 | 202 | (provide 'aforth-compile) 203 | -------------------------------------------------------------------------------- /src/arg-parser.el: -------------------------------------------------------------------------------- 1 | (require 'cl) 2 | 3 | (defun arg-parse-error (msg) 4 | (message msg) 5 | (kill-emacs)) 6 | 7 | (defun verify-commandline-spec (spec) 8 | (let ((spec-checkers '((lambda (x) (unless (eq x 'position) 9 | (let (ret) 10 | (dolist (name x) 11 | (unless (stringp name) 12 | (setq ret "invalid name type"))) 13 | ret))) 14 | (lambda (x) (unless (listp x) "expect list type for arglist" )) 15 | (lambda (x) (unless (stringp x) "expect string type for docstring")))) 16 | error-str fn s funcs current-form) 17 | (while (and spec (not error-str)) 18 | (setq s (car spec) 19 | current-form s 20 | spec (cdr spec) 21 | funcs spec-checkers) 22 | (unless (>= (length s) 4) 23 | (arg-parse-error (format "Expected length >= 4: '%s' " s))) 24 | (while (and spec-checkers s funcs (not error-str)) 25 | (setq fn (car funcs) 26 | funcs (cdr funcs) 27 | item (car s) 28 | s (cdr s)) 29 | (setq error-str (funcall fn item)))) 30 | (when error-str 31 | (arg-parse-error (format "command-line option spec error: '%s', form='%s" error-str current-form))))) 32 | 33 | (defmacro popn (lst n) 34 | "remove and return the first N items of list LST as a list" 35 | (assert (symbolp lst)) 36 | `(let ((__list ,lst) 37 | (__n ,n) 38 | ret) 39 | (while (and __list (> __n 0)) 40 | (setq ret (cons (car __list) ret) 41 | __list (cdr __list) 42 | __n (1- __n))) 43 | (setq ,lst __list) 44 | (nreverse ret))) 45 | 46 | (defun print-arg-help (spec cmd-name) 47 | (let (positional optional) 48 | (dolist (arg spec) 49 | (let ((keys (pop arg)) 50 | (argnames (pop arg)) 51 | (doc (pop arg))) 52 | (if (eq keys 'position) 53 | (push (cons (upcase (symbol-name (car argnames))) doc) positional) 54 | (when (and doc (> (length doc) 0)) 55 | (push (cons keys doc) optional))))) 56 | (message "%s [OPTIONS] %s\n" cmd-name (mapconcat 'car positional " ")) 57 | (dolist (p positional) 58 | (message (car p)) 59 | (message (concat " " (cdr p)))) 60 | (message "\nOPTIONS:") 61 | (dolist (o optional) 62 | (message (mapconcat 'identity (car o) ", ")) 63 | (message (concat " " (cdr o)))))) 64 | 65 | (defun parse-args (spec &optional arg-list no-default) 66 | (verify-commandline-spec spec) 67 | 68 | (let ((args (or arg-list (and (not no-default) (cdr command-line-args)))) 69 | names doc body positional-args named-args fn) 70 | 71 | (dolist (s spec) 72 | (if (eq (car s) 'position) 73 | (setq positional-args (cons (cons 'lambda (cdr s)) positional-args)) 74 | 75 | (dolist (name (car s)) 76 | (setq named-args (cons `(,name . (lambda ,@(cdr s))) named-args))))) 77 | 78 | (while args 79 | (setq a (car args) 80 | args (cdr args)) 81 | (setq fn (cdr (assoc a named-args))) 82 | (if fn 83 | (progn 84 | (setq nargs (length (cadr fn))) 85 | (setq fn-args (popn args nargs)) 86 | (when (not (= (length fn-args) nargs)) 87 | (arg-parse-error (format "Option %s expected at least %d args" a nargs))) 88 | (apply fn fn-args)) 89 | 90 | (setq fn (car positional-args) 91 | positional-args (cdr positional-args)) 92 | (if fn 93 | (funcall fn a) 94 | (arg-parse-error (format "Unexpected arg: %s" a)))) 95 | ))) 96 | 97 | (provide 'arg-parser) 98 | -------------------------------------------------------------------------------- /src/assemble.rkt: -------------------------------------------------------------------------------- 1 | #lang racket ;; -*- lexical-binding: t -*- 2 | 3 | (require "common.rkt" 4 | "el.rkt") 5 | 6 | (when elisp? (_def '(assemble-word assemble))) 7 | 8 | (provide assemble-word assemble) 9 | 10 | (defconst const-masks (vector #x3ffff #x3ff #xff #x7)) 11 | (defconst xor-bits (vector #b1010 #b10101 #b1010 #b101)) 12 | (define (xor-inst inst slot) (bitwise-xor inst (vector-ref xor-bits slot))) 13 | 14 | (define (assemble-inst word slot shift) 15 | ;;Assemble the instruction from WORD in SLOT, SHIFTed to its proper location 16 | ;;If the given slot contains an address, it is returned unchanged 17 | ;;If the slot contains false, as unused slots do, return 0 18 | (let ((inst (vector-ref word slot))) 19 | (if (string? inst) 20 | (begin (unless (vector-member inst opcodes) 21 | (printf "attempt to assemble invalid opcode: '~a'\n" inst) 22 | (exit 1)) 23 | (arithmetic-shift (xor-inst (floor (/ (vector-member inst opcodes) 24 | (if (= slot 3) 4 1))) 25 | slot) 26 | shift)) 27 | ;;slot contains an address, number, or is unused 28 | (or (and inst (& (vector-ref const-masks slot) inst)) 0)))) 29 | 30 | (define (assemble-word word) 31 | (cond ((number? word) 32 | (& word #x3ffff)) 33 | ;;in the assembled memory vector, false represents unused words 34 | ((or (equal? word (vector false false false false)) 35 | (not word)) 36 | #x134a9) ;; call warm 37 | (else (let* ((d (assemble-inst word 3 0)) 38 | (c (assemble-inst word 2 3)) 39 | (b (assemble-inst word 1 8)) 40 | (a (assemble-inst word 0 13))) 41 | (bitwise-ior a b c d))))) 42 | 43 | (define (assemble compiled) 44 | ;;COMPILED is a struct of type 'compiled' 45 | ;;This function mutates the node structs, assembling the words in place 46 | (define nodes (compiled-nodes compiled)) 47 | (define node false) 48 | (define mem false) 49 | (define mem-length false) 50 | (define used-words false) 51 | (while (not (null? nodes)) 52 | (begin 53 | (set! node (car nodes)) 54 | (set! nodes (cdr nodes)) 55 | (set! mem (node-mem node)) 56 | (set! mem-length (vector-length mem)) 57 | (set! used-words (get-compiled-size mem)) 58 | (for ((i used-words)) 59 | (vector-set! mem i (assemble-word (vector-ref mem i)))) 60 | (while (< used-words mem-length) 61 | (begin (vector-set! mem used-words false) 62 | (set! used-words (add1 used-words)))) 63 | )) 64 | compiled) 65 | 66 | (define (get-compiled-size mem) 67 | (let ((meml (reverse (vector->list mem))) 68 | (i 0)) 69 | (while (and (not (null meml)) 70 | (or (not (car meml)) 71 | (equal? (car meml) (vector false false false false)))) 72 | (begin (set! i (add1 i)) 73 | (set! meml (cdr meml)))) 74 | (- (vector-length mem) i))) 75 | -------------------------------------------------------------------------------- /src/bootstream.rkt: -------------------------------------------------------------------------------- 1 | #lang racket ;; -*- lexical-binding: t -*- 2 | 3 | (require "assemble.rkt" 4 | "disassemble.rkt" 5 | "compile.rkt" 6 | "common.rkt" 7 | "el.rkt") 8 | 9 | (when elisp? 10 | (_def '(make-bootstream-type 11 | make-bootstream 12 | make-async-bootstream 13 | make-sync-bootstream 14 | sget-convert 15 | print-bootstream 16 | async-bootstream 17 | sync-bootstream))) 18 | 19 | (provide make-bootstream-type 20 | make-bootstream 21 | make-async-bootstream 22 | make-sync-bootstream 23 | sget-convert 24 | print-bootstream 25 | async-bootstream 26 | sync-bootstream) 27 | 28 | ;;paths are lists of N, E, S, and W directions, 29 | ;;which is the direction of the the current node (starting with `start') 30 | ;;that the stream will take. 31 | 32 | ;;path1 from DB004 page 31 33 | (defconst path1 (let ((NENW (append (cons N (make-list 16 E)) 34 | (cons N (make-list 16 W))))) 35 | (append (make-list 9 E) 36 | (make-list 7 S) 37 | (make-list 17 W) 38 | NENW NENW NENW 39 | (cons N (make-list 7 E)) 40 | (list false)))) 41 | 42 | ;;path0 from DB004 page 31 43 | (defconst target-sync-path (let ((SWSE (append (cons S (make-list 16 W)) 44 | (cons S (make-list 16 E)))) 45 | (SW (cons S (make-list 17 W)))) 46 | (append (make-list 4 N) 47 | (make-list 17 E) 48 | SWSE SWSE SW 49 | (cons S (make-list 17 E)) 50 | SW 51 | (list false)))) 52 | 53 | ;; the host-sync-path only goes from 708 to 300 54 | (defconst host-sync-path (cons S (append (make-list 8 W) 55 | (make-list 3 S)))) 56 | 57 | (defconst async-bootstream (bootstream "async" 708 path1)) 58 | (defconst sync-bootstream (bootstream "sync" 300 target-sync-path)) 59 | (defconst host-sync-bootstream (bootstream "host-sync" 708 host-sync-path)) 60 | 61 | ;; we generate the bootstream for the nodes backwards - the 62 | ;; last node in the chain first. 63 | ;; 'port-pump' generates code to move the bootstream 64 | ;; for the nodes later in the stream through the current node. 65 | ;; 'load-pump' loads the code for a given node into its ram. 66 | 67 | (define (word a (b false) (c false) (d false)) (assemble-word (vector a b c d))) 68 | 69 | (define (port-pump coord dir len) 70 | ;;(printf "(~a)port-pump jump direction: ~a\n" coord (get-direction coord dir)) 71 | (vector (word "@p" "dup" "a!" ".") 72 | (word "call" (get-direction coord dir)) 73 | (word "@p" "push" "!" ".") 74 | (word (sub1 len)) 75 | (word "@p" "!" "unext" "."))) 76 | 77 | (define (load-pump len) 78 | (if len 79 | (vector (word "@p" "a!" "@p" ".") 80 | (word 0);;TODO: will be set by descriptors 81 | (word (sub1 len)) 82 | (word "push" "." "." ".") 83 | (word "@p" "!+" "unext" ".")) 84 | (vector (word ";")))) 85 | 86 | (define (make-node-index-map assembled) 87 | ;; place nodes into an array that maps node indexes to nodes 88 | ;; this allows constant time node lookup 89 | (let ((nodes (make-vector 144 false))) 90 | (for ((node assembled)) 91 | (vector-set! nodes (coord->index (node-coord node)) node)) 92 | nodes)) 93 | 94 | (define coord-changes (vector 100 1 -100 -1)) ;; N, E, S, W coordinate changes 95 | 96 | (define (make-async-frame1 nodes assembled bootstream) 97 | ;;make frame 1 of the async bootstream, loads code for all nodes except the first 98 | (let* (;; ordered-nodes is a list of node objects in the reverse order 99 | ;; that the bootstream visites them - or in the order that they) 100 | ;; have code loaded into their ram. 101 | (ordered-nodes '()) 102 | (start (bootstream-start bootstream)) 103 | (path (bootstream-path bootstream)) 104 | (first-dir (car path)) 105 | (coord (+ start (vector-ref coord-changes first-dir))) 106 | (path (cdr path)) 107 | (len 0) 108 | (code (vector)) 109 | (node false) 110 | (node-code false) 111 | (nothing (vector))) 112 | (define nodes (make-node-index-map assembled)) 113 | ;;create list of nodes in order the bootstream will visit them 114 | ;;If the node is not used then its value will be (coordinate . false) 115 | (for ((dir path)) 116 | (set! ordered-nodes (cons (or (vector-ref nodes (coord->index coord)) 117 | (create-node coord false 0)) 118 | ordered-nodes)) 119 | (when dir 120 | (set! coord (+ coord (vector-ref coord-changes dir))))) 121 | ;; now generate the actual bootstream 122 | (define rpath (reverse path)) 123 | (for ((dir rpath) 124 | (prev (cdr (append rpath (list first-dir))))) 125 | (set! node (car ordered-nodes)) 126 | (set! ordered-nodes (cdr ordered-nodes)) 127 | (set! node-code (and (node-mem node) (get-used-portion (node-mem node)))) 128 | (set! code (vector-append 129 | ;;focusing call 130 | (vector (word "call" 131 | (get-direction (node-coord node) 132 | (vector-ref (vector S W N E) 133 | prev)))) 134 | ;;move all the previous code through this node 135 | (if (> len 0) 136 | (port-pump (node-coord node) dir len) 137 | nothing) 138 | (or code nothing) 139 | ;;then load this nodes code into ram 140 | (load-pump (and node-code 141 | (vector-length node-code))) 142 | (if node-code node-code nothing) 143 | 144 | (if node-code 145 | (vector-append 146 | ;; set a 147 | (if (node-a node) 148 | (vector (word "@p" "a!" "." ".") 149 | (word (node-a node))) 150 | nothing) 151 | ;; set io 152 | (if (node-io node) 153 | (vector (word "@p" "@p" "b!" ".") 154 | (node-io node) 155 | (word #x15D) ;; io 156 | (word "!b" "." "." ".")) 157 | nothing) 158 | ;; set b 159 | (if (node-b node) 160 | (vector (word "@p" "b!" "." ".") 161 | (word (node-b node))) 162 | nothing) 163 | ;; load stack values 164 | (if (node-stack node) 165 | (vector (word "@p" "push") 166 | (word (sub1 (length (node-stack node)))) 167 | (word "@p" "unext")) 168 | nothing) 169 | (if (node-stack node) (list->vector (node-stack node)) nothing) 170 | 171 | ;; jump to starting address 172 | (vector (word "jump" (or (node-p node) 0))) 173 | ) 174 | nothing) 175 | )) 176 | (set! len (vector-length code))) 177 | ;; create the bootframe 178 | (vector-append 179 | (vector #xae 180 | (get-direction start (car path)) 181 | len) 182 | code))) 183 | 184 | (define (make-bootstream-type assembled bootstream) 185 | ;; ASSEMBLED is a list of 'node' structs 186 | ;; returns an array of assembled words 187 | ;; BOOTSTREAM is of type struct bootstream 188 | 189 | (define nodes (make-node-index-map assembled)) 190 | (define frame1 (make-async-frame1 nodes assembled bootstream)) 191 | (define start-node 192 | (vector-ref nodes (coord->index (bootstream-start bootstream)))) 193 | (define code (if start-node 194 | (get-used-portion (node-mem start-node)) 195 | (vector))) 196 | (define nothing (vector)) 197 | (define frame2 (vector-append 198 | (vector (or (and start-node 199 | (node-p start-node)) 0) 0 (vector-length code)) 200 | code 201 | ;; ;boot descriptors for first node 202 | ;; (if (and start-node (node-a start-node)) 203 | ;; (vector (word "@p" "a!" "." ".") 204 | ;; (word (node-a start-node))) 205 | ;; nothing) 206 | ;; ;; set io 207 | ;; (if (and start-node (node-io start-node)) 208 | ;; (vector (word "@p" "@p" "b!" ".") 209 | ;; (node-io start-node) 210 | ;; (word #x15D) ;; io 211 | ;; (word "!b" "." "." ".")) 212 | ;; nothing) 213 | ;; ;; set b 214 | ;; (if (and start-node (node-b start-node)) 215 | ;; (vector (word "@p" "b!" "." ".") 216 | ;; (word (node-b start-node))) 217 | ;; nothing) 218 | )) 219 | (vector-append frame1 frame2)) 220 | 221 | (define (make-bootstream assembled (type default-bootstream-type)) 222 | (unless (member type bootstream-types) 223 | (error (rkt-format "Invalid bootstream type: ~a (Options: ~a)\n" 224 | type (string-join bootstream-types ", ")))) 225 | 226 | (define nodes (compiled-nodes assembled)) 227 | (cond ((equal? type "async") 228 | (make-async-bootstream nodes)) 229 | ((equal? type "2wire") 230 | (make-bootstream-type nodes sync-bootstream)) 231 | ((equal? type "async-target") 232 | (make-sync-bootstream nodes)))) 233 | 234 | (define (make-async-bootstream assembled) 235 | ;; Standard async bootstream. Starts at 708 and visits all nodes. 236 | (make-bootstream-type assembled async-bootstream)) 237 | 238 | (define (make-sync-bootstream assembled) 239 | ;; creates a bootstream to load ASSEMBED code into target chip through 240 | ;; the host chip over the node 300 synchronous port 241 | (define wire ": wire 242 | 260000 for @ !b unext 243 | wire") 244 | ;; host-loader-code moves the target chips bootstream from the host chip's 245 | ;; node 708 to node 300 and sends it to the target chip using the async port. 246 | (define host-loader-code (rkt-format " 247 | node 608 north a! west b! ~a 248 | node 607 east a! west b! ~a 249 | node 606 east a! west b! ~a 250 | node 605 east a! west b! ~a 251 | node 604 east a! west b! ~a 252 | node 603 east a! west b! ~a 253 | node 602 east a! west b! ~a 254 | node 601 east a! west b! ~a 255 | node 600 east a! south b! ~a 256 | node 500 0x20000 io b! !b 257 | 10000 for . . next 258 | 0 !b 259 | north a! south b! ~a 260 | node 400 north a! south b! ~a 261 | 262 | node 300 263 | ( reference: block 632 ) 264 | : dly !b 32 for unext ; 265 | : 1bt dup dly 0x10000 or dly ; 266 | : c+d+ 0x30003 1bt ; ( set clock high, data high, etc) 267 | : c+d- 0x30002 1bt ; 268 | : c-d+ 0x20003 1bt ; 269 | : c-d- 0x20002 1bt ; 270 | : bit- 271 | -if c+d+ ; then c+d- ; 272 | : bit+ 273 | -if c-d+ ; then c-d- ; 274 | : send 275 | 8 for 276 | bit- 2* 277 | bit+ 2* 278 | next 279 | : loop 280 | @ send 281 | loop ; 282 | : main 283 | north a! io b! 284 | @ 0x30000 dly send loop ; 285 | " wire wire wire wire wire wire wire wire wire wire wire)) 286 | 287 | ;; bootstream that is loaded into target chip through node 300 sync port 288 | (define target-bootstream (make-bootstream-type assembled sync-bootstream)) 289 | ;;(define bootstream host-sync-bootstream) 290 | (define bootstream async-bootstream) 291 | (define host-start (bootstream-start bootstream)) 292 | (define host-path (bootstream-path bootstream)) 293 | ;; Compile the host loader code 294 | (define host-code (compiled-nodes (assemble (aforth-compile host-loader-code)))) 295 | (define nodes (make-node-index-map assembled)) 296 | ;; create bootstream for host chip. The first frame loads the code to move the 297 | ;; bootstream to node 300, the second frame contains the target chips bootstream 298 | 299 | (vector-append 300 | ;;frame 1 301 | (make-async-frame1 nodes host-code bootstream) 302 | ;;frame 2 303 | (vector-append (vector 0 304 | ;;(get-direction host-start (car host-path)) 305 | (get-direction host-start S) 306 | (vector-length target-bootstream)) 307 | target-bootstream) 308 | ;;(vector 0 0 0 0) 309 | )) 310 | 311 | (define (sget-convert bootstream) 312 | ;; convert bootstream words to the byte format expected by node 708 313 | ;; bootstream is an array of 18 bit words 314 | (define new '()) 315 | (for ((n bootstream)) 316 | (set! new (cons (^ (& (>> n 10) #xff) #xff) 317 | (cons (^ (& (>> n 2) #xff) #xff) 318 | (cons (^ (ior (& (<< n 6) #xc0) #x2d) #xff) 319 | new))))) 320 | (reverse new)) 321 | 322 | (define (get-used-portion mem) 323 | ;; trim empty words from end of memory vector 324 | (let ((mem (reverse (vector->list mem)))) 325 | (while (and (not (null mem)) 326 | (not (car mem))) 327 | (set! mem (cdr mem))) 328 | (list->vector (reverse mem)))) 329 | 330 | (define (print-bootstream bs) 331 | (for ((word bs)) 332 | (printf "~a ~a\n" word (disassemble-word word)))) 333 | -------------------------------------------------------------------------------- /src/compare.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | #compare racket and elisp compilation results 4 | 5 | ./dump --bootstream async $@ > /tmp/out_1 6 | ./ga $@ > /tmp/out_2 7 | diff /tmp/out_1 /tmp/out_2 8 | 9 | -------------------------------------------------------------------------------- /src/convert.rkt: -------------------------------------------------------------------------------- 1 | #lang racket ;; -*- lexical-binding: t -*- 2 | ;; convert output of dump-rom.py 3 | 4 | (require "rkt-to-el.rkt") 5 | 6 | (define file "raw-rom-dump.txt") 7 | 8 | (define lines (file->lines file)) 9 | (define (next) 10 | (let ((line (car lines))) 11 | (set! lines (cdr lines)) 12 | line)) 13 | 14 | (with-output-to-file "rom-dump.rkt" 15 | (lambda () 16 | (printf "#lang racket ;; -*- lexical-binding: t -*-\n(provide (all-defined-out))\n") 17 | (printf "(define ROM-DUMP (list\n") 18 | (for/list ((node (range 144))) 19 | (print (for/list ((word (range 65))) (string->number (next)))) 20 | (printf "\n")) 21 | (printf "))"))) 22 | -------------------------------------------------------------------------------- /src/disassemble.rkt: -------------------------------------------------------------------------------- 1 | #lang racket ;; -*- lexical-binding: t -*- 2 | 3 | (require "common.rkt" 4 | "el.rkt") 5 | 6 | (when elisp? (_def '(disassemble-nodes display-disassemble disassemble-word))) 7 | 8 | (provide disassemble-nodes 9 | display-disassemble 10 | disassemble-word) 11 | 12 | (define (disassemble-inst from from^ to index start end jump) 13 | ;;FROM is the integer we are disassembling 14 | ;;FROM^ = FROM ^ 0x15555 15 | ;;TO is a vector we disassemble into 16 | ;;START, END mark the bit positions of the instruction in FROM 17 | ;;JUMP is the size of the jump field in FROM, false if none 18 | (let ((inst (vector-ref opcodes (* (bitwise-bit-field from^ start end) 19 | (if jump 1 4))))) 20 | (vector-set! to index inst) 21 | (if (and (member inst address-required) 22 | (< index 3)) 23 | (begin (vector-set! to (add1 index) (bitwise-bit-field from 0 jump)) 24 | false) 25 | (not (member inst instructions-using-rest-of-word))))) 26 | 27 | (define (disassemble-word word) 28 | (let ((to (make-vector 4 false)) 29 | (word^ (and word (bitwise-xor word #x15555)))) 30 | (and word 31 | (disassemble-inst word word^ to 0 13 18 10) 32 | (disassemble-inst word word^ to 1 8 13 8) 33 | (disassemble-inst word word^ to 2 3 8 3) 34 | (disassemble-inst word word^ to 3 0 3 false)) 35 | to)) 36 | 37 | (define (disassemble-nodes nodes) 38 | ;;NODES is a list of 'node' structs 39 | ;;mutates the structs 'mem' field in place 40 | (for ((node nodes)) 41 | (define mem (node-mem node)) 42 | (for ((i (node-len node))) 43 | (vector-set! mem i (disassemble-word (vector-ref mem i)))))) 44 | 45 | (define (display-disassemble compiled (all? false)) 46 | ;;like `disassemble' but also prints out the disassemble and the original words 47 | (assert (not elisp?)) 48 | (define nodes (compiled-nodes compiled)) 49 | 50 | (define (display-word word (n 0)) 51 | (let ((inst false)) 52 | (for ((n 4)) 53 | (set! inst (vector-ref word n)) 54 | (when inst 55 | (printf (rkt-format "~a " inst)))))) 56 | 57 | (define (dis-mem mem) 58 | (define i 0) 59 | (while (and (< i 64) 60 | (or all? 61 | (vector-ref mem i))) 62 | (begin 63 | (printf (rkt-format "~a " i)) 64 | (define word (vector-ref mem i)) 65 | (define dis (disassemble-word word)) 66 | (printf (~a word #:min-width 6 #:align 'right #:left-pad-string " ")) 67 | (printf " ") 68 | (display-word dis) 69 | (newline) 70 | (set! i (add1 i))))) 71 | 72 | (for ((node nodes)) 73 | (printf (rkt-format "\nnode ~a\n" (node-coord node))) 74 | (dis-mem (node-mem node)))) 75 | -------------------------------------------------------------------------------- /src/dump-rom.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python 2 | 3 | from cal import * 4 | from serial import Serial 5 | 6 | speed = 460800 7 | if len(argv) not in [2,3]: 8 | print "Usage: ./dump-rom.py port [speed={}]".format(speed) 9 | exit(1) 10 | 11 | port = argv[1] 12 | 13 | bootstream = run_command("racket rom-dump-bootstream.rkt") 14 | serial = Serial(port, speed) 15 | write("".join(map(chr, bootstream)), serial) 16 | listen(port, speed, serial, verbose=False) 17 | -------------------------------------------------------------------------------- /src/el.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require compatibility/defmacro) 4 | 5 | (provide (all-defined-out)) 6 | 7 | (defmacro assert (x) 8 | `(unless ,x 9 | (error ,(format "Assertion failed: ~a" x)))) 10 | 11 | (defmacro el-require (feature) 12 | #f 13 | ) 14 | 15 | (defmacro defvar (symbol initval) 16 | `(define ,symbol ,initval) 17 | ) 18 | 19 | (defmacro defconst (symbol initval) 20 | `(define ,symbol ,initval) 21 | ) 22 | 23 | 24 | (defmacro setq (var val) 25 | `(let [(__v__ ,val)] 26 | (set! ,var __v__) __v__)) 27 | 28 | (defmacro while (condition code) 29 | `(letrec ((fn (lambda () 30 | (when ,condition 31 | ,code 32 | (fn))))) 33 | (fn))) 34 | 35 | (defmacro push (item list) 36 | `(set! ,list (cons ,item ,list))) 37 | 38 | (defmacro pop (list) 39 | `(if (equal? ,list '()) 40 | (pretty-display "ERROR: pop -- list is empty") 41 | (begin0 (car ,list) (set! ,list (cdr ,list))))) 42 | 43 | (defmacro test-require (x) 44 | x) 45 | 46 | 47 | ;; (define rkt-require require) ;;ERROR: not at module level or top level 48 | ;; (defmacro rkt-provide (files) ;;TODO: syntax for many args 49 | ;; `(provide ,@ 50 | ;; 51 | (define t #t) 52 | (define nil #f) 53 | 54 | (define (fn x) x) 55 | 56 | (define elisp? #f) 57 | (define racket? #t) 58 | 59 | (define _char-hash #\#) 60 | (define _char-0 #\0) 61 | (define _char-x #\x) 62 | (define _char-b #\b) 63 | (define _char-close-paren #\)) 64 | (define _char-newline #\newline) 65 | (define _char-& #\&) 66 | (define _char-space #\ ) 67 | 68 | (define (_def syms) 0) 69 | 70 | (define make-set set) 71 | 72 | ;;;;;;;;;;; 73 | ;;; need to define these to something for the compiler. these functions are not called when code is executed as racket 74 | (define aforth-token-value true) 75 | (define aforth-token-start true) 76 | (define aforth-token-end true) 77 | (define aforth-token-type true) 78 | (define subseq true) 79 | (define (funcall fn) (fn)) 80 | (define (funcall1 fn a) (fn a)) 81 | (define (funcall2 fn a b) (fn a b)) 82 | (define require true) 83 | (define with-temp-buffer true) 84 | (define insert true) 85 | (define write-file true) 86 | (define message printf) 87 | (define concat true) 88 | (define unread-last-tok true) 89 | (define aforth-print-error-data true) 90 | (define error-data-p true) 91 | (define throw true) 92 | (define aforth-error-message true) 93 | (define most-positive-fixnum false) 94 | (define princ false) 95 | 96 | (define rkt-format format) 97 | (define token-start false) 98 | (define token-end false) 99 | (define intern false) 100 | (define mapc false) 101 | (define gethash false) 102 | 103 | -------------------------------------------------------------------------------- /src/ga-compile-print.rkt: -------------------------------------------------------------------------------- 1 | #lang racket ;; -*- lexical-binding: t -*- 2 | 3 | (require "common.rkt" 4 | "compile.rkt" 5 | "assemble.rkt" 6 | "bootstream.rkt" 7 | "disassemble.rkt" 8 | "el.rkt") 9 | 10 | (provide (all-defined-out)) 11 | 12 | (define (compiled->json compiled) 13 | (comma-join 14 | (for/list ((node (compiled-nodes compiled))) 15 | (rkt-format "'~a' : [~a]" 16 | (node-coord node) 17 | (comma-join (let ((mem (node-mem node))) 18 | (for/list ((i (range (node-len node)))) 19 | (let ((word (vector-ref mem i))) 20 | (if (vector? word) 21 | (rkt-format "[~a]" 22 | (comma-join (for/list ((w word)) 23 | (rkt-format "'~a'" (or w "~"))))) 24 | word))))))))) 25 | 26 | (define (boot-descriptors->json compiled) 27 | (comma-join 28 | (for/list ((node (compiled-nodes compiled))) 29 | (rkt-format " '~a' : {~a}" 30 | (node-coord node) 31 | (comma-join (list (rkt-format "'a' : ~a" (or (node-a node) "None")) 32 | (rkt-format "'b' : ~a" (or (node-b node) "None")) 33 | (rkt-format "'io' : ~a"(or (node-io node) "None")) 34 | (rkt-format "'p' : ~a" (or (node-p node) "None")) 35 | (rkt-format "\n'stack' : ~a \n" 36 | (if (node-stack node) 37 | (rkt-format "[~a]" 38 | (comma-join (node-stack node))) 39 | "None")))))))) 40 | (define (symbols->json compiled) 41 | (let ((syms '()) 42 | (symbols false)) 43 | (for/list ((node (compiled-nodes compiled))) 44 | (set! symbols (node-symbols node)) 45 | (unless (null? symbols) 46 | (push (rkt-format "'~a' : {~a}" 47 | (node-coord node) 48 | (comma-join 49 | (for/list ((sym (node-symbols node))) 50 | (rkt-format "'~a' : {'address' : ~a, 'line' : ~a, 'col' : ~a}" 51 | (symbol-val sym) (symbol-address sym) 52 | (symbol-line sym) (symbol-col sym))))) 53 | syms))) 54 | (comma-join syms))) 55 | 56 | (define (assembled->json assembled) 57 | (comma-join (for/list ((node (compiled-nodes assembled))) 58 | (rkt-format "'~a' : [~a]" 59 | (node-coord node) 60 | (comma-join (let ((mem (node-mem node))) 61 | (for/list ((i (range (node-len node)))) 62 | (vector-ref mem i)))))))) 63 | 64 | (define (elisp-maybe-print-and-exit compiled) 65 | ;; temporary method of dealing with the error types returned from the elisp version 66 | (when (and elisp? 67 | (compiled-error-info compiled)) 68 | (aforth-print-error-data compiled) 69 | (exit))) 70 | 71 | (define (print-json input-file (bootstream-type false) (symbols? false)) 72 | (define compiled (aforth-compile-file input-file)) 73 | (elisp-maybe-print-and-exit compiled) 74 | (define compiled-json (compiled->json compiled)) 75 | (define boot-descriptors-json (boot-descriptors->json compiled)) 76 | (define symbols-json (symbols->json compiled)) 77 | (define assembled (assemble compiled)) 78 | (define assembled-json (assembled->json assembled)) 79 | 80 | (define bootstream (sget-convert (make-bootstream assembled (or (bootstream-type) default-bootstream-type)))) 81 | 82 | (define x (list (rkt-format "'file' : '~a'\n" input-file) 83 | (rkt-format "'compiled': {~a}\n" compiled-json) 84 | (rkt-format "'boot-descriptors' : {~a}\n" boot-descriptors-json) 85 | (rkt-format "'assembled': {~a}\n" assembled-json))) 86 | 87 | (when (symbols?) 88 | (set! x (append x (list (rkt-format "'symbols': {~a}\n" symbols-json))))) 89 | 90 | (when (bootstream-type) 91 | (set! x (append x (list (rkt-format "'bootstream' : [~a] " 92 | (comma-join bootstream)))))) 93 | 94 | (printf "{~a}\n" (comma-join x))) 95 | 96 | (define (ga-n val (hex? false) (pre false)) 97 | (let ((n (abs val)) 98 | (s (if (< val 0) "-" ""))) 99 | (rkt-format (if hex? "~a~a~x" "~a~a~a") s (if (and hex? pre) "0x" "") n))) 100 | 101 | (define (print-count input-file) 102 | (define compiled (aforth-compile-file input-file)) 103 | (elisp-maybe-print-and-exit compiled) 104 | (define total 0) 105 | (define (percent a b) 106 | (exact->inexact (* (/ (* a 1.0) b) 100))) 107 | (for ((n (compiled-nodes compiled) hex?)) 108 | (printf "~a ~a~a ~a%\n" 109 | (node-coord n) 110 | (node-len n) 111 | (if (> (node-len n) 64) "*" " ") 112 | (percent (node-len n) 64)) 113 | (set! total (+ total (node-len n)))) 114 | (printf "Total: ~a nodes, ~a words, ~a%\n" 115 | (length (compiled-nodes compiled)) total (percent total (* 64 144)))) 116 | 117 | (define (ga-make-symbol-hash syms) 118 | (let ((ht (make-hash))) 119 | (for ((sym syms)) 120 | (hash-set! ht (symbol-address sym) (symbol-val sym) )) 121 | ht)) 122 | 123 | (define (ga-print-get-name ht index) 124 | (if (hash-has-key? ht index) 125 | (hash-ref ht index) 126 | false)) 127 | 128 | (define (print-pretty input-file (hex? false)) 129 | (define compiled (aforth-compile-file input-file)) 130 | (elisp-maybe-print-and-exit compiled) 131 | (define compiled-hash (make-hash)) 132 | (for ((node (compiled-nodes compiled))) 133 | (hash-set! compiled-hash (node-coord node) 134 | (vector-copy (node-mem node)))) 135 | 136 | 137 | (define assembled (assemble compiled)) 138 | 139 | (define i 0) 140 | (define name false) 141 | 142 | (define hex? (hex?)) 143 | (define (pad-print thing (pad 20)) 144 | (let* ((s (rkt-format "~a" thing)) 145 | (len (string-length s)) 146 | (str (string-append s (make-string (- pad len) _char-space)))) 147 | (printf str))) 148 | 149 | (define (make-pretty thing) 150 | (if (vector? thing) 151 | (vector->list thing) 152 | thing)) 153 | 154 | (for ((node (compiled-nodes assembled))) 155 | (define coord (node-coord node)) 156 | (define symbols (ga-make-symbol-hash (node-symbols node))) 157 | (define comp (hash-ref compiled-hash coord)) ;;why not access directly??? 158 | (define asm (node-mem node)) 159 | (define word false) 160 | (printf "\n\n__________________ node ~a ____________________\n" coord) 161 | (printf "P = ~a\n" (ga-n (or (node-p node) 0) hex?)) 162 | (printf " Compiled Assembled Disassembled\n") 163 | (for ((i (node-len node))) 164 | (set! word (vector-ref comp i)) 165 | (unless (equal? word (vector false false false false)) 166 | (set! name (ga-print-get-name symbols i)) 167 | (when name (printf "~a:\n" name)) 168 | (printf "~a " (ga-n i hex?)) 169 | (pad-print (make-pretty word)) 170 | (pad-print (rkt-format "~a" (ga-n (vector-ref asm i) hex?)) 13) 171 | (printf "~a\n" (make-pretty (disassemble-word (vector-ref asm i)))))))) 172 | 173 | 174 | (define ga-transfer-insts '("jump" "call" "next" "if" "-if")) 175 | 176 | (define (ga-get-transfer-addr word) 177 | ;; return the destination address if word contains a transfer instruction, nil if none 178 | (when (vector? word) 179 | (let ((addr false) 180 | (instr false) 181 | (i 0)) 182 | (while (< i (length word)) 183 | (set! instr (vector-ref word i)) 184 | (if (member instr ga-transfer-insts) 185 | (begin (set! addr (vector-ref word (1+ i))) 186 | (set! i 5)) 187 | (set! i (add1 i)))) 188 | addr))) 189 | 190 | (define (ga-collect-transfer-addrs mem len) 191 | (let ((a false) 192 | (h (make-hash))) 193 | (for ((i len)) 194 | (set! a (ga-get-transfer-addr (vector-ref mem i))) 195 | (when a 196 | (if (hash-has-key? address-names a) 197 | (hash-set! h a (hash-ref address-names a)) 198 | (hash-set! h a (format "_%s" i))) 199 | )) 200 | h)) 201 | 202 | (define (print-bowman-format input-file (hex? false) (full true) (aforth-sim false)) 203 | (when full (printf "include(ga144.hdr)\n")) 204 | (define compiled (aforth-compile-file input-file)) 205 | (elisp-maybe-print-and-exit compiled) 206 | (define (make-pretty thing) 207 | (if (vector? thing) 208 | (vector->list thing) 209 | thing)) 210 | (define hex? (hex?)) 211 | (define (get-addr* name) 212 | (or (get-address name) 213 | (cdr (assoc name io-places)))) 214 | 215 | (define (print-boot-descriptor word val) 216 | (when val 217 | (printf (format " %s\n %s\n" word val)))) 218 | 219 | (for ((node (compiled-nodes compiled))) 220 | (define coord (node-coord node)) 221 | (define symbols (ga-make-symbol-hash (node-symbols node))) 222 | 223 | (define mem (node-mem node)) 224 | (define len (node-len node)) 225 | (define word false) 226 | (printf (format "\n\n---------------------------- %03d ----------------------------\n" 227 | coord)) 228 | (when (and full (not aforth-sim)) 229 | (print-boot-descriptor "@p a!" (node-a node)) 230 | (when (node-io node) 231 | (printf " @p @p b!\n") 232 | (printf " ~a\n" (node-io node)) 233 | (printf " 0x15d\n") ;; io 234 | (printf " !b\n")) 235 | (print-boot-descriptor "@p b!" (node-b node)) 236 | (when (node-stack node) 237 | (for ((val (node-stack node))) 238 | (printf " @p\n") ;:TODO: load multiple per word 239 | (printf " ~a\n" val))) 240 | 241 | ;;initial jump currently defaults to 0 so don't insert an extra jump 242 | ;; => ga144tools version always inserts jump, GA144-watch requires jump 243 | (printf " jump ~a\n" (or (node-p node) 0)) 244 | 245 | (printf ": __start\n")) 246 | (when aforth-sim 247 | (when (and (node-p node) 248 | (not (member "main" (hash-values symbols)))) 249 | (printf "/p ~a\n" (node-p node))) 250 | (when (node-io node) 251 | (printf "/io ~a\n" (node-io node))) 252 | (when (node-b node) 253 | (printf "/b ~a\n" (node-b node))) 254 | (when (node-a node) 255 | (printf "/a ~a\n" (node-a node))) 256 | (when (node-stack node) 257 | (error "printing /stack is unimplemented"))) 258 | 259 | (define addr-names (ga-collect-transfer-addrs mem len)) 260 | (define ok false) 261 | (define a false) 262 | 263 | (define (get-name i) 264 | (or (ga-print-get-name symbols i) 265 | (hash-ref addr-names i))) 266 | 267 | (for ((i len)) 268 | (set! word (vector-ref mem i)) 269 | (if (or (not word) 270 | (equal? word (vector false false false false))) 271 | (printf ".\n");;correct? 272 | (begin 273 | (set! name (get-name i)) 274 | (when name 275 | (printf ": ~a\n" name)) 276 | 277 | (printf " ") 278 | (set! ok true) 279 | (set! comment false) 280 | (for ((instr (if (number? word) 281 | (list (ga-n word hex? true)) 282 | word)) 283 | (i 4)) 284 | (when (and instr ok) 285 | (printf "~a " instr) 286 | (when (member instr ga-transfer-insts) 287 | (set! a (vector-ref word (1+ i))) 288 | (set! name (get-name a)) 289 | (if name 290 | ;; convert names like ---l to their address 291 | (begin (set! a (get-addr* name)) 292 | (set! comment (and a (format " \\ %s" name))) 293 | (set! name (or a name))) 294 | (set! name a)) 295 | (printf "~a" name) 296 | (when comment (printf comment)) 297 | (set! ok false)))) 298 | (printf "\n") 299 | ))))) 300 | -------------------------------------------------------------------------------- /src/ga-loadup.el: -------------------------------------------------------------------------------- 1 | ;; -*- lexical-binding: t -*- 2 | 3 | (setq byte-compiled-p (file-exists-p "ga-main.elc")) 4 | 5 | (require 'cl) 6 | 7 | (defun ga-rkt-load (file) 8 | (let ((lexical-binding t) 9 | (racket? nil)) 10 | (flet ((require (&rest files) nil) 11 | (provide (&rest syms) nil)) 12 | (if byte-compiled-p 13 | (load (concat file ".elc") nil t) 14 | (rkt-load file)))) 15 | t) 16 | 17 | (defun ga-el-load (file) 18 | 19 | (load file nil t)) 20 | 21 | (setq _ga_loadup_file load-file-name) 22 | 23 | (defun ga-compiler-loadup () 24 | (let ((lexical-binding t) 25 | (buffer-file-name _ga_loadup_file)) 26 | (ga-el-load "rkt.el") 27 | 28 | (ga-rkt-load "rom.rkt") 29 | (ga-rkt-load "rom-dump.rkt") 30 | (ga-rkt-load "common.rkt") 31 | (ga-rkt-load "compile.rkt") 32 | (ga-rkt-load "bootstream.rkt") 33 | (ga-rkt-load "assemble.rkt") 34 | (ga-rkt-load "disassemble.rkt") 35 | (ga-rkt-load "ga-compile-print.rkt") 36 | 37 | (ga-el-load "rkt") 38 | (ga-el-load "aforth-parse") 39 | (ga-el-load "aforth-mode") 40 | (ga-el-load "arg-parser") 41 | ;;(ga-el-load "ga144-sim") 42 | (ga-el-load "aforth-compile")) 43 | t) 44 | 45 | (defun ga-tests-loadup() 46 | (let ((lexical-binding t) 47 | (buffer-file-name _ga_loadup_file)) 48 | (ga-rkt-load "../tests/test-compiler.rkt"))) 49 | 50 | (defun ga-sim-loadup() 51 | (let ((lexical-binding t) 52 | (buffer-file-name _ga_loadup_file)) 53 | (ga-rkt-load "f18a.rkt") 54 | (ga-rkt-load "ga144.rkt") 55 | (ga-rkt-load "stack.rkt") 56 | (ga-el-load "ga144-sim") 57 | )) 58 | ;; (ga-compiler-loadup) 59 | ;; (ga-sim-loadup) 60 | 61 | (defun ga-loadup() 62 | (ga-compiler-loadup) 63 | (ga-sim-loadup) 64 | ;;(message (if (featurep 'ga144-sim) "YES" "NO")) 65 | ) 66 | 67 | 68 | (provide 'ga-loadup) 69 | -------------------------------------------------------------------------------- /src/ga-main.el: -------------------------------------------------------------------------------- 1 | ;; -*- lexical-binding: t -*- 2 | 3 | (setq aforth-file-extensions '("aforth" "af" "ga")) 4 | 5 | (setq debug-on-error t) 6 | (setq load-start-time (current-time)) 7 | 8 | (require 'cl) 9 | (require 'gv) 10 | (put 'flet 'byte-obsolete-info nil) ;;prevent message "‘flet’ is an obsolete macro.." 11 | 12 | (setq bootstream? nil) 13 | (setq bootstream-type "async") 14 | (setq symbols? nil) 15 | (setq pretty? nil) 16 | (setq count? nil) 17 | (setq hex? nil) 18 | (setq in-file nil) 19 | (setq byte-compile? nil) 20 | (setq profile? nil) 21 | (setq create-docs? nil) 22 | (setq test? nil) 23 | (setq test-all? nil) 24 | (setq only-bootstream? nil) 25 | (setq run? nil) 26 | (setq verbose? nil) 27 | (setq working-dir nil) 28 | (setq bowman-format? nil) 29 | (setq bowman-expand? nil) 30 | (setq print-bowman? nil) 31 | (setq sim? nil) 32 | (setq sim-bootstream? "") 33 | (setq ga-only-print-nodes nil) 34 | (setq ga-print-execution-time? nil) 35 | 36 | (let ((base (file-name-directory (or buffer-file-name load-file-name)))) 37 | (setq ga-base-dir (file-name-directory (substring base 0 -1)))) 38 | 39 | (add-to-list 'load-path (concat ga-base-dir "src")) 40 | (add-to-list 'load-path (concat ga-base-dir "tests")) 41 | 42 | (require 'arg-parser) 43 | 44 | (setq ga-arg-spec '((("-b" "--bootstream") nil "include bootstream" 45 | (setq bootstream? t)) 46 | (("--bootstream-type") (type) "bootstream type" 47 | (setq bootstream-type type)) 48 | (("--only-bootstream") nil "only output loadable bootstream" 49 | (setq only-bootstream? t)) 50 | (("-s" "--symbols") nil "include symboltable" 51 | (setq symbols? t)) 52 | (("-p" "--pretty") nil "print in human readable" 53 | (setq pretty? t)) 54 | (("-c" "--count") nil "count ram usage" 55 | (setq count? t)) 56 | (("-x" "--hex") nil "print numbers in hexadecimal format" 57 | (setq hex? t)) 58 | (("-n" "--node") (n) "Only print data for select nodes" 59 | (setq ga-only-print-nodes (cons n ga-only-print-nodes))) 60 | (("--byte-compile") nil "byte compile .rkt files" 61 | (setq byte-compile? t)) 62 | (("--profile") nil "save cpu profile data in file INFILE_profile" 63 | (setq profile? t)) 64 | (("--create-docs") nil "generate documentation" 65 | (setq create-docs? t)) 66 | (("-t" "--test") nil "run compiler tests" ;;TODO -t, -T does not work "Option '-T' requires an argument" 67 | (setq test? t)) 68 | (("-T" "--test-all") nil "run all tests (compiler + simulator)" 69 | (setq test? t 70 | test-all? t)) 71 | (("-r" "--run") nil "run in simulator" ;;TODO: -r option does not work 72 | (setq run? t)) 73 | (("-v" "--verbose") nil "" 74 | (setq verbose? t)) 75 | (("-h") nil "print usage" 76 | (ga-print-help-and-exit)) 77 | (("--wd") (dir) "" ;; for internal use 78 | ;;(cd dir) 79 | (setq working-dir dir)) 80 | (("--bowman") nil "" 81 | (setq bowman-format? t)) 82 | (("--bowman-expand") nil "expand .ga into aforth compatible format and print" 83 | (setq bowman-expand? t)) 84 | (("--print-as-bowman") nil "" 85 | (setq print-bowman? t)) 86 | (("--sim") nil "" 87 | (setq sim? t)) 88 | (("--sim-bootstream") nil "" 89 | (setq sim? t 90 | sim-bootstream? "--sim-bootstream")) 91 | (("--print-gc") nil "" 92 | (add-hook 'post-gc-hook (lambda () (message "GC: %ss(%s)" gc-elapsed gcs-done)))) 93 | (("--print-time") nil "print an estimate node execution time when the program exists" 94 | (setq ga-print-execution-time? t)) 95 | (("--no-gc") nil "" 96 | (setq gc-cons-threshold most-positive-fixnum)) 97 | (position (file) "aforth file" 98 | (setq in-file file)) 99 | )) 100 | 101 | (defun ga-print-help-and-exit () 102 | (print-arg-help ga-arg-spec "ga") 103 | (kill-emacs)) 104 | 105 | (when (<= (length command-line-args) 5) 106 | (ga-print-help-and-exit)) 107 | 108 | (parse-args ga-arg-spec (cdddr command-line-args) t) 109 | 110 | (when profile? 111 | (require 'profiler) 112 | (profiler-start 'cpu)) 113 | 114 | ;(require 'aforth-compile) 115 | ;(require 'ga-serial) 116 | 117 | (setq racket-script-mode t) 118 | 119 | (load "ga-loadup.el" nil t) 120 | (ga-compiler-loadup) 121 | 122 | (setq bowman-format bowman-format?) 123 | 124 | (when only-bootstream? 125 | (setq verbose? nil)) 126 | 127 | (when verbose? 128 | (message "load time: %s" (float-time (time-since load-start-time)))) 129 | 130 | (defun ga-byte-compile-files () 131 | (setq lexical-binding t) 132 | (dolist (file '("src/bootstream.rkt" 133 | "src/assemble.rkt" 134 | "src/compile.rkt" 135 | "src/disassemble.rkt" 136 | "src/ga-compile-print.rkt" 137 | "src/common.rkt" 138 | "src/rom.rkt" 139 | "src/rom-dump.rkt" 140 | "tests/test-compiler.rkt" 141 | "src/ga144.rkt" 142 | "src/f18a.rkt" 143 | "src/stack.rkt" 144 | )) 145 | (rkt-byte-compile (expand-file-name file))) 146 | 147 | (dolist (file '("src/ga-main.el" 148 | "src/aforth-compile.el" 149 | "src/aforth-mode.el" 150 | "src/ga144-map.el" 151 | "src/aforth-parse.el" 152 | "src/arg-parser.el" 153 | "src/rkt.el" 154 | "src/ga-loadup.el" 155 | "src/ga144-sim.el" 156 | "src/ga-run-simulator.el" 157 | )) 158 | (byte-compile-file (expand-file-name file)))) 159 | 160 | (defun ga-main-exit () 161 | (when profile? 162 | (let ((profile-filename (concat "_profile_" (or in-file "")))) 163 | (profiler-report) 164 | (profiler-report-write-profile profile-filename) 165 | (message "saved profile data in file: '%s', view with M-x profiler-find-profile" profile-filename) 166 | )) 167 | (exit)) 168 | 169 | (when byte-compile? 170 | (setq _start-time (current-time)) 171 | (require 'vc-git) ;; for vc-git-root, because basic-save-buffer calls vc-after-save, but why? 172 | 173 | ;;(dolist (file (set->list rkt-loaded-files)) 174 | ;; (rkt-byte-compile (expand-file-name file))) 175 | (ga-byte-compile-files) 176 | (when verbose? 177 | (message "byte-compile time: %s" (float-time (time-since _start-time)))) 178 | (ga-main-exit)) 179 | 180 | (when create-docs? 181 | (require 'vc-git) 182 | (write-directive-docs "compiler-directives") 183 | (ga-main-exit)) 184 | 185 | (when test? 186 | (ga-tests-loadup) 187 | (message (if (run-compiler-tests) 188 | "ok" 189 | "fail")) 190 | 191 | (when test-all? 192 | (require 'ga-tests) 193 | (run-simulation-tests) 194 | (ga-main-exit)) 195 | (ga-main-exit)) 196 | 197 | (when (and in-file (not (file-exists-p in-file))) 198 | (message "File does not exist: %s\n" in-file) 199 | (ga-main-exit)) 200 | 201 | (setq file-extension (file-name-extension in-file)) 202 | 203 | (when (not (or (member file-extension aforth-file-extensions) 204 | (string= file-extension "el"))) 205 | (message "Error: unknown file type") 206 | (ga-main-exit)) 207 | 208 | (require 'ga144-sim) 209 | 210 | (defun ga-require-ga144-sim () 211 | (require 'ga144-sim) 212 | (setq ga-print-execution-time ga-print-execution-time?)) 213 | 214 | (when (string= file-extension "el") 215 | (ga-require-ga144-sim) 216 | (load (expand-file-name in-file working-dir)) 217 | (ga-main-exit)) 218 | 219 | (when run? 220 | (ga-require-ga144-sim) 221 | (ga144-run-file (expand-file-name in-file)) 222 | (ga-main-exit)) 223 | 224 | (when sim? 225 | (shell-command (concat "ga-sim " in-file " " sim-bootstream?)) 226 | (ga-main-exit)) 227 | 228 | (when bowman-expand? 229 | (with-temp-buffer 230 | (convert-from-bowman-format in-file) 231 | (message (buffer-string))) 232 | (ga-main-exit)) 233 | 234 | (progn ;;for .rkt compatibility 235 | (defun bootstream-type () bootstream-type) 236 | (defun symbols? () symbols?) 237 | (defun hex? () hex?)) 238 | 239 | (setq _start-time (current-time)) 240 | 241 | (when only-bootstream? 242 | (princ (mapconcat 'number-to-string (compile-file-to-bootstream in-file bootstream-type) " ") standard-output) 243 | (ga-main-exit)) 244 | 245 | (cond (count? (print-count in-file)) 246 | (pretty? (print-pretty in-file hex?)) 247 | (print-bowman? (print-bowman-format in-file hex?)) 248 | (t (print-json in-file bootstream-type symbols?))) 249 | 250 | (when verbose? 251 | (message "compile time: %s" (float-time (time-since _start-time)))) 252 | 253 | (ga-main-exit) 254 | -------------------------------------------------------------------------------- /src/ga-run-simulator.el: -------------------------------------------------------------------------------- 1 | ;; -*- lexical-binding: t -*- 2 | 3 | ;; script for running the simulation as a standalone application 4 | ;; 5 | ;; emacs -l ga-run-simulator.el FILE.aforth 6 | 7 | (toggle-debug-on-error) 8 | (load-theme 'wombat t) 9 | (set-cursor-color "#ff4500") 10 | (setq frame-title-format "GA144") 11 | 12 | (require 'cl) 13 | (require 'gv) 14 | (put 'flet 'byte-obsolete-info nil) 15 | (add-to-list 'default-frame-alist '(fullscreen . maximized)) 16 | (setq inhibit-startup-message t) 17 | (if (fboundp 'scroll-bar-mode) (scroll-bar-mode -1)) 18 | (if (fboundp 'tool-bar-mode) (tool-bar-mode -1)) 19 | (if (fboundp 'menu-bar-mode) (menu-bar-mode -1)) 20 | ;;(set-fringe-mode 0) 21 | ;;(kill-buffer "*scratch*") 22 | ;;(setq message-log-max nil) 23 | ;;(kill-buffer "*Messages*") 24 | 25 | (blink-cursor-mode 0) 26 | 27 | (when (< (length command-line-args) 5) 28 | (princ "Usage: ga-sim FILE\n" #'external-debugging-output) 29 | (kill-emacs)) 30 | 31 | (setq base (file-name-directory (or buffer-file-name load-file-name)) 32 | base (file-name-directory (substring base 0 -1))) 33 | 34 | (add-to-list 'load-path (concat base "src")) 35 | 36 | (setq dir (nth 3 command-line-args)) 37 | (setq filename (concat (file-name-as-directory dir) (nth 4 command-line-args))) 38 | 39 | (load "ga-loadup.el") 40 | (ga-loadup) 41 | 42 | (setq ga-load-bootstream (member "--sim-bootstream" command-line-args)) 43 | 44 | (setq ga-default-node-size 6) 45 | 46 | (when (string= (file-name-extension filename) "ga") 47 | (setq bowman-format t)) 48 | 49 | (defun open-sim () 50 | (find-file filename) 51 | (setq mode-line-format filename) 52 | (read-only-mode 1) 53 | 54 | (buffer-disable-undo) 55 | (setq ga-sim-buffer (ga-open-map-for-simulation (current-buffer))) 56 | (switch-to-buffer ga-sim-buffer) 57 | ;;(pop-to-buffer-same-window ga-sim-buffer) 58 | ;;(set-window-buffer (selected-window) ga-sim-buffer) 59 | ;;(pop-to-buffer ga-sim-buffer) 60 | 61 | (setq mode-line-format "Simulation") 62 | ;;(redraw-display) 63 | ;;(redraw-frame) 64 | (delete-other-windows) 65 | (message "")) 66 | 67 | 68 | ;;for some reason this must be called after some delay or the 69 | ;;map buffer will not be visible 70 | ;;the delay must be > 0.0001 71 | (run-at-time 0.001 nil 'open-sim) 72 | (message "") 73 | -------------------------------------------------------------------------------- /src/ga-serial.el: -------------------------------------------------------------------------------- 1 | 2 | ;; https://www.gnu.org/software/emacs/manual/html_node/elisp/Serial-Ports.html 3 | 4 | (defun ga144-scan () 5 | "scan for connected GA144 devices" 6 | (error "ga144-scan unimplemented")) 7 | 8 | (defun ga144-find-serial-port () 9 | (error "ga144-find-serial-port unimplemented") 10 | ) 11 | 12 | (defun ga-get-connected-serial-devices () 13 | (directory-files "/dev/serial/by-id" t ".*\\([^.]\\|[^..]\\)$")) 14 | 15 | ;;(ga-make-serial "/dev/ttyS0" 9600) 16 | 17 | (defun ga144-serial-open (port speed &optional flowcontrol sentinel filter) 18 | (when (eq port 'auto) 19 | (setq port (ga144-find-serial-port))) 20 | (make-serial-process :port port 21 | :speed speed 22 | ;;:flowcontrol (or flowcontrol 'hw) 23 | :sentinel (or sentinel 'ga-serial-sentinel) 24 | :filter (or filter 'ga-serial-filter) 25 | :coding 'no-conversion 26 | :noquery t 27 | )) 28 | 29 | (defun ga-serial-close (serial) 30 | "close SERIAL port" 31 | (delete-process serial)) 32 | 33 | (defun ga-serial-sentinel (proc state) 34 | "Sentinel for GA serial port processes" 35 | (message "ga-serial-sentinel %s -- '%s'" proc state)) 36 | 37 | (defun ga-serial-filter (proc str) 38 | "Filter for GA serial port processes" 39 | (message "received input form process %s" proc) 40 | (message " input = %s" str) 41 | (message " words = %s" (ga-process-input proc str)) 42 | ) 43 | 44 | (defun ga-build-word (byte-array index) 45 | (logand (logior (ash (aref byte-array index) 16) 46 | (ash (aref byte-array (+ index 1) 8)) 47 | (aref byte-array (+ index 2))) 48 | #x3ffff) 49 | ) 50 | 51 | (defun ga-process-input (serial str) 52 | "Process input byte string from GA144 SERIAL processs, 53 | returns list of transmitted words" 54 | (message "ga-process-input %s %s" serial str) 55 | (let ((bytes (string-to-vector str)) 56 | (n-bytes (length bytes)) 57 | (n-words (/ n-bytes 4)) 58 | (alive t) 59 | code words word byte) 60 | (when (not (= (* n-words 4) n-bytes)) 61 | (message "ERROR: received partial input TODO FIX")) 62 | 63 | (dotimes (and alive (i n-words)) 64 | (setq code (aref bytes (+ i 3))) 65 | (cond ((= code 0) ;;read word 66 | (push (ga-build-word bytes i) words)) 67 | ((= code 1) ;;exit 68 | (setq alive nil) 69 | (ga-serial-close serial) 70 | (message "*** ga144 serial closed by device ***")) 71 | ((= code 2) ;;input 72 | (ga-serial-request-input serial (ga-build-word bytes i))) 73 | (t (message "Received invalid word code: %s" code)))) 74 | words)) 75 | 76 | (defun ga-serial-request-input (serial n-bytes) 77 | "read N-BYTES from user and send to SERIAL process" 78 | ) 79 | 80 | (defun ga-serial-write (serial bytes) 81 | (process-send-string serial (mapconcat 'char-to-string bytes ""))) 82 | 83 | (defun ga-serial-read (port) 84 | ) 85 | 86 | (provide 'ga-serial) 87 | -------------------------------------------------------------------------------- /src/ga.rkt: -------------------------------------------------------------------------------- 1 | #lang racket ;; -*- lexical-binding: t -*- 2 | 3 | (require compatibility/defmacro 4 | "compiler/compile.rkt" 5 | "el.rkt") 6 | 7 | (provide (all-defined-out)) 8 | 9 | (define ret 'ret) 10 | (define ex 'ex) 11 | (define jump 'jump) 12 | (define call 'call) 13 | (define unext 'unext) 14 | (define next 'next) 15 | ;(define if 'if) 16 | (define -if '-f) 17 | (define @p '@p) 18 | (define @+ '@+) 19 | (define @b '@b) 20 | (define @ '@) 21 | (define !p '!p) 22 | (define !b '!b) 23 | (define ! '!) 24 | (define +* '+*) 25 | (define 2* '2*) 26 | (define 2/ '2/) 27 | ;;(define - '-) 28 | ;;(define + '+) 29 | (define and 'and) 30 | (define or 'or) 31 | ;;(define drop 'drop) 32 | (define dup 'dup) 33 | (define pop 'pop) 34 | (define over 'over) 35 | (define a 'a) 36 | (define nop 'nop) 37 | (define push 'push) 38 | (define b! 'b!) 39 | (define a! 'a!) 40 | 41 | (define io 'io) 42 | (define north 'north) 43 | (define east 'east) 44 | (define south 'south) 45 | (define west 'west) 46 | (define up 'up) 47 | (define down 'down) 48 | (define left 'left) 49 | (define right 'right) 50 | 51 | ;;(define for 'for) ;X 52 | 53 | (define op-replacements (make-hash '(("ret" . ";") 54 | ("nop" . ".")))) 55 | (struct GA144 (name nodes) #:mutable #:transparent) 56 | (struct Node (coord words) #:mutable #:transparent) 57 | (struct Word (name body) #:mutable #:transparent) 58 | 59 | (define current-node-list false) 60 | (define (set-current-node-list! x) (set! current-node-list x)) 61 | (define (get-current-node-list) current-node-list) 62 | (define (current-node-list-add! x) 63 | (set! current-node-list (cons x current-node-list))) 64 | 65 | (define chips (list)) 66 | (define (add-chip chip) (set! chips (cons chip chips))) 67 | (define (get-chips) chips) 68 | 69 | (define current-word-list false) 70 | (define (set-current-word-list! x) (set! current-word-list x)) 71 | (define (get-current-word-list) current-word-list) 72 | (define (current-word-list-add! x) 73 | (set! current-word-list (cons x current-word-list))) 74 | 75 | (define-syntax-rule (chip name nodes ...) 76 | (begin (define name (GA144 (symbol->string 'name) false)) 77 | (add-chip name) 78 | (set-current-node-list! (list)) 79 | nodes ... 80 | (set-GA144-nodes! name (reverse (get-current-node-list))) 81 | (set-current-node-list! false))) 82 | 83 | (define-syntax-rule (node coord words ...) 84 | (begin (set-current-word-list! (list)) 85 | words ... 86 | (current-node-list-add! (Node coord (reverse (get-current-word-list)))) 87 | (set-current-word-list! false))) 88 | 89 | (define-syntax-rule (: name inst ...) 90 | (begin (define name (quote name)) 91 | (create-word (symbol->string name) (list inst ...)))) 92 | 93 | (define (create-word name instructions) 94 | (current-word-list-add! 95 | (Word name 96 | (for/list ((inst instructions)) 97 | (let ((s (cond ((symbol? inst) 98 | (symbol->string inst)) 99 | ;;else: numbers 100 | (else inst)))) 101 | (if (hash-has-key? op-replacements s) 102 | (hash-ref op-replacements s) 103 | s))) 104 | ))) 105 | 106 | (struct Comment (text)) 107 | 108 | (define-syntax-rule (c text ...) 109 | (Comment (string-join (for/list ((x (quote (text ...)))) 110 | (if (equal? x 'nl) 111 | "\n" 112 | (rkt-format "~a" x))) 113 | " "))) 114 | 115 | (define (write-aforth-file (chip false) [name "out.aforth"]) 116 | (with-output-to-file name 117 | (lambda () 118 | (printf "( autogenerated code ***do not edit*** chip=~a )\n" 119 | (GA144-name chip)) 120 | (for ((n (GA144-nodes chip))) 121 | (printf "\nnode ~a\n" (Node-coord n)) 122 | (for ((word (Node-words n))) 123 | (printf ": ~a\n" (Word-name word)) 124 | (for ((inst (Word-body word))) 125 | (printf "~a " inst)) 126 | (printf "\n")))) 127 | #:exists 'replace)) 128 | -------------------------------------------------------------------------------- /src/ga144-sim.el: -------------------------------------------------------------------------------- 1 | ;; -*- lexical-binding: t -*- 2 | 3 | (rkt-load "ga144.rkt") 4 | (rkt-load "f18a.rkt") 5 | (rkt-load "stack.rkt") 6 | 7 | (require 'aforth-compile) 8 | (require 'rkt) 9 | 10 | (setq ga-print-execution-time nil) 11 | 12 | (defun ga144-run-file (file) 13 | (let* ((compiled (aforth-compile-file file)) 14 | (assembled (assemble compiled)) 15 | (chip (make-ga144 (file-name-base file) nil))) 16 | 17 | (send chip load assembled) 18 | (send (send chip coord->node 705) set-pin! 0 t) ;; set 705.17 high to prevent spi boot 19 | (send chip step-program!*) 20 | (when ga-print-execution-time 21 | (ga-print-execution-time chip)) 22 | )) 23 | 24 | (setq ga144-chips nil) 25 | (setq ga144-name-to-chip nil) 26 | (setq num-chips nil) 27 | 28 | (defun ga144-new (name &optional buffer) 29 | (let ((chip (make-ga144 name t buffer))) 30 | (push chip ga144-chips) 31 | (hash-set! ga144-name-to-chip name chip) 32 | (set! num-chips (add1 num-chips)) 33 | chip)) 34 | 35 | (defun ga144-get-node (chip coord) 36 | (send chip coord->node coord)) 37 | 38 | (defun ga144-connect-pins (from-node from-pin to-node to-pin) 39 | (let ((wire (lambda (x) 40 | ;; (printf "(WIRE ~a) ~a.~a<-->~a.~a\n" x 41 | ;; (send from-node get-coord) from-pin 42 | ;; (send to-node get-coord) to-pin) 43 | (send to-node set-pin! to-pin (= x 3))))) 44 | (send from-node set-gpio-handler from-pin wire))) 45 | 46 | 47 | (setq ga-probe-count 0) 48 | (setq ga-probes (make-hash-table)) 49 | 50 | (defun ga-new-probe () 51 | (let ((id ga-probe-count)) 52 | (puthash id nil ga-probes) 53 | (setq ga-probe-count (1+ id)) 54 | id)) 55 | 56 | (defun ga-probe-record (node probe-id state) 57 | (let* ((state (if (= state 3) 1 0)) 58 | (history (gethash probe-id ga-probes)) 59 | (last-time (car (car history))) 60 | (last-state (cdr (car history))) 61 | (time (send (send node get-ga144) get-time))) 62 | (when last-state 63 | (setq history (cons (cons time last-state) history))) 64 | (puthash probe-id (cons (cons time state) history) ga-probes))) 65 | 66 | (defun ga-connect-probe (node pin) 67 | (let* ((probe-id (ga-new-probe)) 68 | (probe (lambda (x) 69 | (ga-probe-record node probe-id x)))) 70 | (send node set-gpio-handler pin probe) 71 | probe-id)) 72 | 73 | (defun ga144-probe-save (&optional filename) 74 | (let ((shift 0)) 75 | (with-temp-buffer 76 | (insert "import matplotlib.pyplot as plt\n") 77 | (maphash (lambda (k v) 78 | (setq v (nreverse v)) 79 | (when v 80 | (insert (format "plt.plot([%s], [%s])\n" 81 | (mapconcat (lambda (x) (number-to-string (car x))) v ",") 82 | (mapconcat (lambda (x) (number-to-string (+ (cdr x) shift))) v ","))) 83 | (setq shift (+ shift 1.02)))) 84 | ga-probes) 85 | ;; TODO: labels 86 | (insert "plt.show()\n") 87 | (write-file (or filename "ga144-probe-graph.py")) 88 | ))) 89 | 90 | (defun ga144-step* (&optional chip) 91 | (let ((chips (or (and chip (list chip)) 92 | ga144-chips)) 93 | (again true) 94 | (breakpoint? nil)) 95 | (setq ga-run-sim t) 96 | 97 | (while (and again 98 | (not breakpoint?) 99 | ga-run-sim) 100 | (set! again nil) 101 | (for ((chip chips)) 102 | (when (and (> (send chip num-active-nodes) 0) 103 | (not breakpoint?)) 104 | (setq again t 105 | breakpoint? (send chip step-program!))))))) 106 | 107 | (defun ga144-clear-all () 108 | (setq ga144-chips nil) 109 | (setq ga144-name-to-chip (make-hash-table)) 110 | (setq num-chips 0)) 111 | 112 | (defun ga-format-ps (time) 113 | (cond ((< time 1000000) 114 | (format "%sns" (/ time 1000))) 115 | ((< time 1000000000) 116 | (format "%sus" (/ time 1000000))) 117 | (t (error "todo")) 118 | )) 119 | 120 | (defun ga-print-execution-time (&optional chip) 121 | (message "node | time\n-----------") 122 | (dolist (x (sort (send chip get-execution-time) 123 | (lambda (a b) (< (cdr a) (cdr b))))) 124 | (if (> (cdr x) 5200) 125 | (printf (format "%-3s %s\n" (car x) (ga-format-ps (cdr x))))))) 126 | 127 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 128 | 129 | (setq ga-extern-functions (make-hash-table)) 130 | 131 | (defmacro ga-define (name &rest body) 132 | "define a function that can be called from a ga144 simulation node with !!name 133 | the node object the function is called from will be bound to 'node'" 134 | `(puthash ',name (lambda (node) ,@body) ga-extern-functions)) 135 | 136 | (ga-define printT 137 | (princ (format "T: %s\n" (car (send node get-dstack-as-list))))) 138 | 139 | (ga-define printS 140 | (princ "S: %s\n" (cadr (send node get-dstack-as-list)))) 141 | 142 | (ga-define break 143 | (send node break "source breakpoint") 144 | (message "breakpoint (node %s)" (send node get-coord))) 145 | 146 | (ga-define _test-inc ;; used by tests 147 | (send node d-push! (1+ (send node d-pop!)))) 148 | 149 | (ga144-clear-all) 150 | 151 | (provide 'ga144-sim) 152 | -------------------------------------------------------------------------------- /src/ga144.rkt: -------------------------------------------------------------------------------- 1 | #lang racket ;; -*- lexical-binding: t -*- 2 | 3 | (define _PORT-DEBUG? false) 4 | (define DISPLAY_STATE? false) 5 | (define port-debug-list '(1 2)) 6 | (define (PORT-DEBUG? coord) (and _PORT-DEBUG? (member coord port-debug-list))) 7 | 8 | (define ga-run-sim t) ;;global variable used for halting the simulation 9 | (define (ga-stop-sim!) 10 | (set! ga-run-sim nil)) 11 | 12 | (define (make-ga144 name_ (interactive_ false) (source-buffer_ false)) 13 | (new ga144% name_ interactive_ source-buffer_)) 14 | 15 | (define ga144% 16 | (class object% 17 | (super-new) 18 | (init-field (name false) (interactive false) (source-buffer false)) 19 | 20 | (define time 0) 21 | (define breakpoint false) ;; set to t when a breakpoint is reached 22 | (define breakpoint-node false) ;;node where breakpoint originated 23 | ;;set by map when it wants the node to update the map with its activity 24 | (define display-node-activity false) 25 | (define map-buffer false) 26 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 27 | ;; 8x18 node matrix 28 | 29 | (define nodes (make-vector 144 false)) 30 | (define/public (get-nodes) nodes) 31 | ;;builds matrix of 144 f18 nodes 32 | (define (build-node-matrix) 33 | (for ((i 144)) 34 | (vector-set! nodes i (new f18a% i this source-buffer))) 35 | (vector-map (lambda (node) (send node init)) nodes)) 36 | 37 | (define (index->node index) 38 | (vector-ref nodes index)) 39 | 40 | (define/public (coord->node coord) 41 | (let ((index (coord->index coord))) 42 | (if (and (>= index 0) 43 | (< index 144)) 44 | (vector-ref nodes index) 45 | false ;;TODO: return pseudo node 46 | ))) 47 | 48 | (define (fn:coord->node coord) 49 | (coord->node coord)) 50 | 51 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 52 | ;; suspension and wakeup 53 | 54 | ;;TODO: better way to clone vector 55 | (define active-nodes false) 56 | ;;index of last active node in the 'active-nodes' array 57 | (define last-active-index 143) ;;all nodes are initially active 58 | 59 | (define current-node-index 0) ;;index into 'active-nodes' of the current node 60 | (define current-node false) 61 | 62 | (define/public (remove-from-active-list node) 63 | (let ((last-active-node (vector-ref active-nodes last-active-index)) 64 | (index (get-field active-index node))) 65 | ;;swap self with current node in 'active-nodes' 66 | (vector-set! active-nodes index last-active-node) 67 | (vector-set! active-nodes last-active-index node) 68 | ;;save the new node indices 69 | (set-field! active-index last-active-node index) 70 | (set-field! active-index node last-active-index) 71 | ;;decrement the number of active nodes 72 | (set! last-active-index (sub1 last-active-index))) 73 | (when show-io-changes? 74 | (print-active))) 75 | 76 | (define/public (add-to-active-list node) 77 | (set! last-active-index (add1 last-active-index)) 78 | (let ((first-inactive-node (vector-ref active-nodes last-active-index)) 79 | (index (get-field active-index node))) 80 | ;;swap self with first inactive node in 'active-nodes' 81 | (vector-set! active-nodes index first-inactive-node) 82 | (vector-set! active-nodes last-active-index node) 83 | ;;save the new node indices 84 | (set-field! active-index first-inactive-node index) 85 | (set-field! active-index node last-active-index)) 86 | (when show-io-changes? 87 | (print-active))) 88 | 89 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 90 | ;; breakpoints 91 | 92 | (define cli-active? false) ;; if true, we are in a cli session 93 | 94 | (define/public (break (node false)) 95 | (set! breakpoint-node node) 96 | ;; set the breakpoint flag which returns control to the interpreter 97 | (set! breakpoint t)) 98 | (define/public (get-breakpoint-node) breakpoint-node) 99 | 100 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 101 | ;; program loading 102 | 103 | (define/public (load compiled) 104 | ;; Places code into each node's RAM/ROM 105 | (reset! false) 106 | (for ((n (compiled-nodes compiled))) 107 | (send (coord->node (node-coord n)) load n)) 108 | ;;(fetch-I) 109 | ) 110 | 111 | (define/public (load-bootstream bs (input-node 708)) 112 | ;;Load a bootstream through INPUT-NODE 113 | (send (coord->node input-node) load-bootstream bs) 114 | (set! time 0)) 115 | 116 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 117 | ;; execution control 118 | 119 | ;; step functions return true if a breakpoint has been reached, else false 120 | 121 | (define/public (step-program! (display-update-ok true)) 122 | (set! breakpoint false) 123 | (set! time (add1 time)) 124 | (define index 0) 125 | ;;(setq inhibit-redisplay t) 126 | (when (>= last-active-index 0) 127 | (while (and (<= index last-active-index) 128 | (not breakpoint)) 129 | (begin 130 | (set! current-node (vector-ref active-nodes index)) 131 | 132 | (unless (and (send current-node step-program!) 133 | (not (= index last-active-index))) 134 | ;; if node gets suspended during this step it will swap itself 135 | ;; with the last active node, declrementing last-active-index. 136 | ;; if that happens we need to step the node at the same index again. 137 | (set! index (add1 index))) 138 | ))) 139 | ;;(setq inhibit-redisplay nil) 140 | (when (and display-node-activity 141 | display-update-ok) 142 | (update-activity)) 143 | ;;TODO: use current-node-index to correctly resume after a breakpoint 144 | breakpoint) 145 | 146 | (define/public (step-program-n! n) 147 | (set! breakpoint false) 148 | (set! ga-run-sim true) 149 | (while (and (> n 0) 150 | (not (or (= last-active-index -1) 151 | breakpoint)) 152 | ga-run-sim) 153 | (setq breakpoint (step-program! false)) 154 | (setq n (1- n))) 155 | (when display-node-activity 156 | (update-activity)) 157 | breakpoint) 158 | 159 | ;;step program until all nodes are non-active 160 | (define/public (step-program!* (max-time false)) 161 | (set! breakpoint false) 162 | (set! ga-run-sim true) 163 | (if max-time 164 | (while (and (not (or (= last-active-index -1) 165 | breakpoint)) 166 | (< time 1000000) 167 | ga-run-sim) 168 | (step-program!)) 169 | (while (and (not (or (= last-active-index -1) 170 | breakpoint)) 171 | ga-run-sim) 172 | (set! breakpoint (step-program! false)))) 173 | (when display-node-activity 174 | (update-activity)) 175 | 176 | ;; (when (= (num-active-nodes) 0) 177 | ;; (when interactive 178 | ;; (printf "[[ All nodes are suspended\n")) 179 | ;; (set! breakpoint t)) 180 | 181 | breakpoint) 182 | 183 | (define/public (fetch-I) 184 | (vector-map (lambda (node) (send node fetch-I)) nodes)) 185 | 186 | (define/public (reset! (fetch true)) 187 | (set! time 0) 188 | (set! active-nodes (vector-copy nodes)) 189 | (set! last-active-index 143) 190 | (set! current-node-index 0) 191 | (set! current-node (vector-ref active-nodes current-node-index)) 192 | (set! breakpoint false) 193 | (set! cli-active? false) 194 | (set! breakpoint-node false) 195 | (vector-map (lambda (node) (send node reset!)) nodes) 196 | (when fetch (fetch-I)) 197 | (when display-node-activity 198 | (update-activity))) 199 | 200 | (define/public (show-activity state) 201 | (set! display-node-activity state) 202 | (when state 203 | (update-activity))) 204 | 205 | (define (update-activity) 206 | (vector-map (lambda (node) 207 | (send node update-map-display time)) 208 | nodes) 209 | (redisplay)) 210 | 211 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 212 | ;; state display functions 213 | 214 | (define/public (get-active-nodes) 215 | (if (>= last-active-index 0) 216 | (for/list ((i (add1 last-active-index))) 217 | (vector-ref active-nodes i)) 218 | '())) 219 | 220 | (define/public (num-active-nodes) 221 | (add1 last-active-index)) 222 | 223 | (define/public (display-node-states (nodes false)) 224 | (let ((nodes (if nodes 225 | (map (lambda (n) (coord->node n)) nodes) 226 | (get-active-nodes)))) 227 | (for ((node nodes)) 228 | (send node display-state)))) 229 | 230 | (define/public (display-dstacks (nodes false)) 231 | (let ((nodes (if nodes 232 | (map (lambda (n) (coord->node n)) nodes) 233 | (get-active-nodes)))) 234 | (for ((node nodes)) 235 | (send node display-dstack)))) 236 | 237 | (define/public (display-memory coord (n MEM-SIZE)) 238 | (send (fn:coord->node coord) display-memory n)) 239 | 240 | 241 | (define/public (print-active) 242 | ;;print a chip diagram showing the active nodes 243 | (define (print-node coord) 244 | (let* ((node (coord->node coord)) 245 | (suspended? (send node suspended?)) 246 | (reading-port (send node get-current-reading-port)) 247 | (writing-port (send node get-current-writing-port))) 248 | (printf "~a" (if suspended? 249 | (or reading-port writing-port " ") 250 | "*")))) 251 | 252 | (printf "--------------------\n") 253 | (for ((row (range 8))) 254 | (printf "|") 255 | (for ((column (range 18))) 256 | (print-node (+ (* (- 7 row) 100) column))) 257 | (printf "|\n")) 258 | (printf "--------------------\n")) 259 | 260 | (define/public (print-node coord) 261 | (send (coord->node coord) display-all)) 262 | 263 | (define show-io-changes? false) 264 | (define/public (show-io-changes show) 265 | (set! show-io-changes? show)) 266 | 267 | (define/public (get-time) time) 268 | (define/public (reset-time) (set! time 0)) 269 | 270 | (define/public (disassemble-memory coord (start 0) (end #xff)) 271 | ;; disassemble and print a nodes memory 272 | (send (coord->node coord) disassemble-memory start end)) 273 | 274 | (define/public (disassemble-local coord) 275 | ;; disassemble and print a nodes memory 276 | (send (coord->node coord) disassemble-local)) 277 | 278 | (define/public (get-execution-time) 279 | (let ((ret nil)) 280 | (for ((node nodes)) 281 | (push (send node get-execution-time) ret)) 282 | ret)) 283 | 284 | (build-node-matrix) 285 | (reset!) 286 | )) 287 | -------------------------------------------------------------------------------- /src/listen.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python 2 | from sys import argv 3 | from serial import Serial 4 | import struct 5 | 6 | 7 | def listen(serial): 8 | def read_n( n ): 9 | x = [ord(serial.read( 1 )) for _ in range( n ) ] 10 | x.reverse() 11 | word = 0 12 | for byte in x: 13 | word = ( word << 8 ) | byte 14 | n -= 1 15 | return word 16 | 17 | while True: 18 | n = read_n( 1 ) 19 | if n == 1: 20 | print "[exit]" 21 | return 22 | if n == 0: 23 | n = read_n( 3 ) 24 | print n & 0x3ffff 25 | else: 26 | print "unknown code:", s 27 | 28 | if __name__ == "__main__": 29 | speed = 460800 30 | if len(argv) not in [2,3]: 31 | print "usage: ./listen.py port [speed={}]".format(speed) 32 | exit(1) 33 | if len(argv) == 3: 34 | speed = argv[2] 35 | port = argv[1] 36 | print "Listening. port={}, speed={}".format(port, speed) 37 | serial = Serial(port, speed) 38 | serial.reset_input_buffer() 39 | listen(serial) 40 | serial.close() 41 | -------------------------------------------------------------------------------- /src/read.rkt: -------------------------------------------------------------------------------- 1 | #lang racket ;; -*- lexical-binding: t -*- 2 | 3 | (require "common.rkt" 4 | "el.rkt") 5 | 6 | (when elisp? 7 | (_def '(read-token 8 | forth-read 9 | forth-read-no-eof 10 | forth-read-char 11 | parse-code 12 | display-parsed-code))) 13 | 14 | (provide read-token 15 | forth-read 16 | forth-read-no-eof 17 | forth-read-char 18 | parse-code 19 | display-parsed-code) 20 | 21 | (define line-number 1) 22 | (define col-number 0) 23 | 24 | (define (syntax-error msg) 25 | (raise (rkt-format "[~a:~a]syntax error: ~a" line-number col-number msg ))) 26 | 27 | (define (read-token in) 28 | (assert (not elisp?)) 29 | (define (get-first-char-in-list) 30 | (let ((new-char (read-char in))) 31 | (cond ((eof-object? new-char) new-char) 32 | ((eq? new-char _char-newline) 33 | (set! line-number (add1 line-number)) 34 | (set! col-number 0) 35 | (get-first-char-in-list)) 36 | ((char-whitespace? new-char) 37 | (set! col-number (add1 col-number)) 38 | (get-first-char-in-list)) 39 | (else (list new-char))))) 40 | 41 | (define (iter lst) 42 | (if (or (eof-object? (peek-char in)) 43 | (eq? (peek-char in) _char-newline)) 44 | (begin (set! col-number (add1 col-number)) 45 | lst) 46 | (let ((new-char (read-char in))) 47 | (set! col-number (add1 col-number)) 48 | (if (char-whitespace? new-char) 49 | (begin (set! col-number (add1 col-number)) 50 | lst) 51 | (iter (cons new-char lst)))))) 52 | 53 | (let ((first-char (get-first-char-in-list)) 54 | (line-no line-number) 55 | (col-no col-number)) 56 | (if (list? first-char) 57 | (let ((tok (list->string (reverse (iter first-char))))) 58 | (token tok line-no col-no)) 59 | (token first-char line-no col-no)))) 60 | 61 | (define (forth-read-char) 62 | (let ((char (read-char))) 63 | (when (eq? char _char-newline) 64 | (set! line-number (add1 line-number)) 65 | (set! col-number 0)) 66 | char)) 67 | 68 | (define (make-reader) 69 | (let ((stack '())) 70 | (lambda ((tok false) (line -1) (col -1)) 71 | (if tok 72 | (set! stack (cons (token tok line col) stack)) 73 | (if (null? stack) 74 | (read-token (current-input-port)) 75 | (begin0 (car stack) 76 | (set! stack (cdr stack)))))))) 77 | 78 | (define forth-read (make-reader)) 79 | 80 | (define (comment) 81 | ;;TODO: update line/col numbers 82 | (unless (equal? (forth-read-char) _char-close-paren) 83 | (comment))) 84 | 85 | (define (parse-code) 86 | (assert (not elisp?)) 87 | ;;returns list of cons: ((NODE . CODELIST)...)) 88 | ;;first item is list of code before the first node. boot descriptors etc 89 | ;;CODELIST is a list of type struct token. 90 | ;; the first two words are the colon and word name 91 | (define nodes '()) 92 | (define current-node-num false) 93 | (define current-node-code false) 94 | 95 | (define (read-loop) 96 | (define tok-token (forth-read)) 97 | (define tok (token-tok tok-token)) 98 | (cond ((equal? tok "(") 99 | (comment) 100 | (read-loop)) 101 | ((equal? tok "node") 102 | (let* ((node-token tok-token) 103 | (num-token (forth-read)) 104 | (node-tok (token-tok node-token)) 105 | (num-tok (token-tok num-token))) 106 | (when (not (eof-object? node-tok)) 107 | (when (or (eof-object? num-tok) 108 | (not (equal? node-tok "node")) 109 | (not (string->number num-tok))) 110 | (syntax-error "malformed node syntax")) 111 | (set! nodes (cons (cons (string->number num-tok) (parse-words)) 112 | nodes)) 113 | (read-loop)))) 114 | ((eof-object? tok) 115 | ;;return 116 | ) 117 | ((equal? tok "bootstream") 118 | (forth-read) ;;TODO: ignoring for now 119 | (read-loop)) 120 | (else (syntax-error (rkt-format "don't know what to do with '~a'" tok))))) 121 | 122 | (read-loop) 123 | (reverse nodes)) 124 | 125 | 126 | (define (parse-words) 127 | ;;returns a list of token lists, one for each word 128 | ;;if a word does not contain and ending ; then it is 129 | ;;merged with the next word 130 | (assert (not elisp?)) 131 | (define words '()) 132 | (define last false) 133 | (define current-word '()) 134 | (define current-name false) 135 | (define done false) 136 | (define (end-word (name false)) 137 | (set! current-word (reverse current-word)) 138 | (when (= (length current-word) 0) 139 | (syntax-error "empty node body")) 140 | (set! words (cons current-word words)) 141 | (set! current-word '())) 142 | 143 | (define (read-loop) 144 | (let* ((token (forth-read)) 145 | (tok (and token (token-tok token)))) 146 | (if (or (eof-object? tok) 147 | done) 148 | (begin 149 | (forth-read tok) 150 | (when (not (null? current-word)) 151 | (when (= (length current-word) 0) (syntax-error "empty node body.")) 152 | (set! words (cons (reverse current-word) words)))) 153 | (begin 154 | (cond ((and (equal? words '()) 155 | (not (equal? current-word null)) 156 | (equal? tok ":")) 157 | ;;code before the first word - create a pseudo word for it 158 | (end-word "_first") ;;TODO: use false instead 159 | (set! current-word (list token))) 160 | 161 | ((and (and last (equal? (token-tok last) ";")) 162 | (equal? tok ":")) 163 | ;;start of a new word 164 | (end-word) 165 | (define name (forth-read)) 166 | (when (or (not name) (eof-object? (token-tok name))) 167 | (syntax-error "expected word name following ':'")) 168 | (set! current-word (list name token))) 169 | ((equal? tok "(") 170 | (comment)) 171 | ((equal? tok "node") 172 | (forth-read tok) 173 | (end-word) 174 | (set! done t)) 175 | (else (set! current-word (cons token current-word)))) 176 | (set! last token) 177 | (read-loop))))) 178 | (read-loop) 179 | (reverse words)) 180 | 181 | (define (forth-read-no-eof) 182 | (assert (not elisp?)) 183 | (let ((res (forth-read))) 184 | (if (eof-object? res) 185 | (error "Unexpected EOF") 186 | res))) 187 | 188 | (define (display-parsed-code parsed-nodes) 189 | (assert (not elisp?)) 190 | ;; (display-parsed-code (parse-code)) 191 | (for/list ((node parsed-nodes)) 192 | (printf "_____________________ node ~a ___________________\n" (car node)) 193 | ;;print boot descriptors 194 | (for/list ((inst (cadr node))) 195 | (printf " ~a " (token-tok inst))) 196 | (printf "\n") 197 | ;;print words 198 | (for/list ((word (cddr node))) 199 | ;; print ": " 200 | (printf " ~a ~a\n" 201 | (token-tok (car word)) 202 | (token-tok (cadr word))) 203 | ;; print word body 204 | (for/list ((inst (cddr word))) 205 | (printf " ~a\n" (token-tok inst)))))) 206 | -------------------------------------------------------------------------------- /src/rom-dump-bootstream.rkt: -------------------------------------------------------------------------------- 1 | #lang racket ;; -*- lexical-binding: t -*- 2 | 3 | ;; Generates code and a bootstream that dumps ROM from every node. 4 | 5 | (require "compile.rkt" 6 | "bootstream.rkt" 7 | "assemble.rkt" 8 | "common.rkt" 9 | "el.rkt") 10 | 11 | (define start (bootstream-start async-bootstream)) 12 | (define path (bootstream-path async-bootstream)) 13 | ;;(define path (take (bootstream-path async-bootstream) 2)) 14 | 15 | (define prev-dir false) 16 | 17 | (define ports '()) 18 | (define coords '()) 19 | (define coord-changes (vector 100 1 -100 -1)) ;; N, E, S, W coordinate changes 20 | (define coord (+ start (vector-ref coord-changes (car path)))) 21 | (set! ports '(469)) 22 | 23 | (for ((dir (cdr path))) 24 | (when dir 25 | (set! ports (cons (get-direction coord dir) ports)) 26 | (set! coords (cons coord coords)) 27 | (set! coord (+ coord (vector-ref coord-changes dir))))) 28 | 29 | (set! coords (cons coord coords)) 30 | 31 | (define code (string-join (for/list ((to ports) 32 | (coord coords) 33 | (from (cons false ports)) 34 | (i (range 144))) 35 | (string-join 36 | (list (rkt-format "node ~a" coord) 37 | (rkt-format "~a b! " (port-name to)) 38 | ;; pump rom from other nodes through this one 39 | (if from 40 | (rkt-format "~a a!\n ~a for @ !b unext" 41 | (port-name from) (sub1 (* i 65))) 42 | "") 43 | ;; send this nodes ID and its ROM 44 | "0x80 a!" 45 | (rkt-format "~a !b" coord) 46 | "63 for @+ !b unext warm") "\n")) 47 | "\n")) 48 | 49 | (set! code (string-append code 50 | "\nnode 708 51 | : emit1 ( n ) 52 | 1 and 3 or !b 53 | 865 for unext ; 54 | : emit8 ( n - n ) 55 | 0 emit1 56 | 7 for dup emit1 2/ next 57 | 1 emit1 ; 58 | : emit18 ( n - n ) 59 | 0xa5 emit8 drop 60 | emit8 emit8 emit8 ; 61 | : main 62 | io b! right a! 63 | 9294 for @ emit18 drop next 64 | 708 emit18 65 | 0x80 a! 66 | 63 for @+ emit18 next 67 | 2375 emit18 68 | warm 69 | ")) 70 | 71 | ;;(printf code) 72 | 73 | (define c (aforth-compile code)) 74 | (define assembled (assemble c)) 75 | 76 | (define (pad-print thing [pad 20]) 77 | (let* ((s (rkt-format "~a" thing)) 78 | (len (string-length s)) 79 | (str (string-append s (make-string (- pad len) #\ )))) 80 | (printf str))) 81 | 82 | (printf "[~a]\n" (comma-join (sget-convert (make-async-bootstream assembled)))) 83 | -------------------------------------------------------------------------------- /src/rom.rkt: -------------------------------------------------------------------------------- 1 | #lang racket ;; -*- lexical-binding: t -*- 2 | 3 | (require "el.rkt") 4 | 5 | (provide (all-defined-out)) 6 | 7 | ;; block 1418 math rom anywhere 8 | (defconst basic-rom '(("relay" . #xa1) ;; 1388 9 | ("warm" . #xa9) ;; warm 10 | ("*.17" . #xb0) ;; 1390 multiply 11 | ("*." . #xb7) ;; 1396 fractional multiply 12 | ("taps" . #xbc) ;; 1386 13 | ("interp" . #xc4) ;; 1384 interpolate 14 | ("triangle" . #xce) ;; 1394 15 | ("clc" . #xd3) ;; 1398 16 | ("--u/mod" . #x2d5) ;; 1398 17 | ("-u/mod" . #x2d6) ;; 1398 18 | ("poly" . #xaa) ;; 1382 polynomial approximation 19 | )) 20 | 21 | ;; block 1432 analog 22 | (defconst analog-rom '(("relay" . #xa1) ;; 1388 23 | ("warm" . #xa9) ;; warm 24 | ("*.17" . #xb0) ;; 1390 multiply 25 | ("*." . #xb7) ;; 1396 fractional multiply 26 | ("-dac" . #xbc) ;; 1434 27 | ("interp" . #xc4) ;; 1384 interpolate 28 | ("triangle" . #xce) ;; 1394 29 | ("clc" . #xd3) ;; 1398 30 | ("--u/mod" . #x2d5) ;; 1398 31 | ("-u/mod" . #x2d6) ;; 1398 32 | ("poly" . #xaa) ;; 1382 polynomial approximation 33 | )) 34 | 35 | ;; block 1420 serdes top/bot 36 | (defconst serdes-boot-rom '(("relay" . #xa1) ;; 1388 37 | ("warm" . #xa9) 38 | ("cold" . #xaa) 39 | ("*.17" . #xb0) ;; 1390 multiply 40 | ("*." . #xb7) ;; 1396 fractional multiply 41 | ("taps" . #xbc) ;; 1386 42 | ("interp" . #xc4) ;; 1384 interpolate 43 | ("triangle" . #xce) ;; 1394 44 | ("clc" . #xd3) ;; 1398 45 | ("--u/mod" . #x2d5) ;; 1398 46 | ("-u/mod" . #x2d6) ;; 1398 47 | ("poly" . #xaa) ;; 1382 polynomial approximation 48 | )) 49 | 50 | ;; block 1422 sync serial boot side 51 | (defconst sync-boot-rom '(("relay" . #xa1) ;; 1388 52 | ("warm" . #xa9) 53 | ("cold" . #xaa) 54 | ("ser-exec" . #xb6) 55 | ("ser-copy" . #xb9) 56 | ("sget" . #xbe) 57 | ("6in" . #xc0) 58 | ("2in" . #xc2) 59 | ("*.17" . #xcc) ;; 1390 multiply 60 | ("taps" . #xd3) ;; 1386 61 | ("triangle" . #xdb) ;; 1394 62 | )) 63 | 64 | ;; block 1424 async serial boot top/bot 65 | (defconst async-boot-rom '(("relay" . #xa1) ;; 1388 66 | ("warm" . #xa9) 67 | ("cold" . #xaa) 68 | ("ser-exec" . #xae) 69 | ("ser-copy" . #xb3) 70 | ("wait" . #xbb) 71 | ("sync" . #xbe) 72 | ("start" . #xc5) 73 | ("delay" . #xc8) 74 | ("18ibits" . #xcb) ;; 1426 75 | ("byte" . #xd0) ;; 1426 76 | ("4bits" . #xd2) ;; 1426 77 | ("2bits" . #xd3) ;; 1426 78 | ("1bit" . #xd4) ;; 1426 79 | ("lsh" . #xd9) ;; 1392 80 | ("rsh" . #xdb))) 81 | ;; 1392 ;??????? 82 | 83 | ;; block 1428 spi boot top/bot 84 | (defconst spi-boot-rom '(("relay" . #xa1) ;; 1388 85 | ("warm" . #xa9) 86 | ("8obits" . #xc2) 87 | ("ibit" . #xc7) 88 | ("half" . #xca) 89 | ("select" . #xcc) 90 | ("obit" . #xd0) 91 | ("rbit" . #xd5) 92 | ("18ibits" . #xd9) 93 | ;;?? ibits, u2/ 94 | ;; block 1430 95 | ("cold" . #xaa) 96 | ("spi-boot" . #xb0) 97 | ("spi-exec" . #xb6) 98 | ("spi-copy" . #xbc))) 99 | 100 | ;; block 1436 1-wire 101 | (defconst 1-wire-rom '(("rcv" . #x9e) 102 | ("bit" . #xa1) 103 | ("warm" . #xa9) 104 | ("cold" . #xaa) 105 | ("triangle" . #xbe) ;; 1394 106 | ("*.17" . #xc3) ;; 1390 107 | ("*." . #xca) ;; 1396 108 | ("interp" . #xcf) ;; 1384 109 | ("clc" . #xcf) ;; 1398 110 | ("--u/mod" . #x2d1) ;; 1398 111 | ("-u/mod" . #x2d2) ;; 1398 ;;TODO: check 112 | )) 113 | 114 | (defconst SDRAM-addr-rom ;; node 9 block 1320 115 | '(("warm". #xa9) 116 | ("cmd" . #xaa))) 117 | 118 | (defconst SDRAM-control-rom ;; node 8 block 1322 119 | '(("warm". #xa9))) 120 | 121 | (defconst SDRAM-data-rom ;; node 7 block 1324 122 | '(("warm". #xa9) 123 | ("db@" . #xaa) 124 | ("db!" . #xb) 125 | ("inpt" . #xad))) 126 | 127 | (defconst eForth-bitsy-rom ;; node 105 block 1306 128 | '(("warm". #xa9) 129 | ("rp--" . #xaa) 130 | ("bs@" . #xac) 131 | ("'else" . #xac) 132 | ("rp@" . #xb0) 133 | ("pshbs" . #xb1) 134 | ("'r@" . #xb3) 135 | ("@w" . #xb4) 136 | ("rfrom" . #xb6) 137 | ("popbs" . #xb9) 138 | ("pshr" . #xbb) 139 | ("rp++" . #xbf) 140 | ("ip++" . #xbf) 141 | ("tor" . #xc1) 142 | ("rp!" . #xc4) 143 | ("'con" . #xc7) 144 | ("'var" . #xc8) 145 | ("'exit" . #xc9) 146 | ("bitsy" . #xce) 147 | ("xxt" . #xd0) 148 | ("'ex" . #xd3) 149 | ("'lit" . #xd5) 150 | ("'if" . #xd8))) 151 | 152 | (defconst eForth-stack-rom ;;node 106 block 1310 153 | '(("warm". #xa9) 154 | ("'c@" . #xaa) 155 | ("'@" . #xaa) 156 | ("x@" . #xaa) 157 | ("sp++" . #xac) 158 | ("char+" . #xac) 159 | ("cell+" . #xac) 160 | ("1+" . #xac) 161 | ("popt" . #xae) 162 | ("sp--" . #xb0) 163 | ("char-" . #xb0) 164 | ("cell-" . #xb0) 165 | ("1-" . #xb0) 166 | ("psht" . #xb2) 167 | ("x!" . #xb4) 168 | ("'c!" . #xb6) 169 | ("'!" . #xb6) 170 | ("popts" . #xb7) 171 | ("pops" . #xb8) 172 | ("pshs" . #xba) 173 | ("page@" . #xbc) 174 | ("pshw" . #xbe) 175 | ("page!" . #xc0) 176 | ("sp@" . #xc3) 177 | ("sp!" . #xc6) 178 | ("'drop" . #xc8) 179 | ("'over" . #xc9) 180 | ("'dup" . #xca) 181 | ("'swap" . #xcb) 182 | ("'2/" . #xcd) 183 | ("um+" . #xcf) 184 | ("'nc" . #xd2) 185 | ("'cy" . #xd3) 186 | ("zless" . #xd8) 187 | ("'or" . #xdb) 188 | ("'xor" . #xdc) 189 | ("'and" . #xdd) 190 | ("negate" . #xde) 191 | ("invert" . #xdf) 192 | ("zeq" . #xe0) 193 | ("'+" . #xe2) 194 | ("swap-" . #xe3))) 195 | 196 | (defconst SDRAM-mux-rom ;; node 107 block 1328 197 | '(("warm". #xa9) 198 | ("a2rc" . #xaa) 199 | ("row!" . #xaf) 200 | ("sd@" . #xbb) 201 | ("sd!" . #xc5) ;;TODO: sd! and poll are not in dumped rom 202 | ("poll" . #xcf))) 203 | 204 | (defconst SDRAM-idle-rom '(("warm". #xa9) 205 | ("noop" . #xaa) 206 | ("cmd" . #xac) 207 | ("idle" . #xae) 208 | ("init" . #xc0))) 209 | 210 | (define (rom-doc name block doc (code false)) 211 | (void)) 212 | 213 | (rom-doc 214 | "relay" 1388 215 | "relay moves a port executable packet down a sequence of nodes linked by their 216 | b registers. the packet consists of a 1-cell index, a 1-cell count less one 217 | of body size, and the body cells. 218 | 219 | a packet may be started from memory within a node, or it may simply be fed 220 | to a port. 221 | 222 | relay assumes that b points to the next node in the chain. uses one return 223 | stack location and four data stack locations. it must be at the same location 224 | in every node.") 225 | 226 | (rom-doc 227 | "warm" false 228 | "") 229 | 230 | (rom-doc 231 | "*.17" 1390 232 | "*.17 multiplies a fraction by a fraction,giving a fraction, or an integer by a 233 | fraction, giving an integer. note that f1 is left in s to be ignored, dropped, 234 | or reused. note that the definition of *. contains a call to this word. 235 | 236 | 17 bit fractions --- s.i ffff ffff ffff ffff ") 237 | 238 | (rom-doc 239 | "*." 1396 240 | "*. multiplies a fraction by a fraction, giving a fraction, or an integer by a 241 | fraction, giving an integer. note that f1 is left in s to be ignored, dropped, 242 | or reused. 243 | 244 | 16 bit fractions --- si. ffff ffff ffff ffff") 245 | 246 | (rom-doc 247 | "taps" 1386 248 | ": taps yxc-y'x' 249 | for example... 250 | 251 | fir yx-y'x' 15 taps -53 , 0 , 2276 , 0 , 382 , 252 | 0 , -1706 , 0 , -1158 , 0 , 2014 , 0 , 2406 , 253 | 0 , -1977 , 0 , -4206 , 0 , 1289 , 0 , 6801 , 254 | 0 , 678 , 0 , -11109 , 0 , -6250 , 0 , 23531 , 255 | 0 , 54145 , 0 , 256 | 257 | 16 taps, 16 coefficients with intermediate cr 258 | storage interleaved.") 259 | 260 | (rom-doc 261 | "interp" 1384 262 | "interp ims-v 263 | to determine values for m and s ... 264 | let l be number of meaningful input bits. let n be power of 2 where 2**n + 1 265 | is the number of table entries. 266 | 267 | s equals l-n-1 cr 268 | m equals 2** l-n - 1 br 269 | 270 | so for example if you have an 8 bit adc, l equals 8. let n equal 2 for a 5 271 | entry table. the table is expected to be at address 0, so to represent 0 to 272 | 1800 millivolts... 273 | 274 | 0 org 0 , 450 , 900 , 1350 , 1800 , 275 | mv i-n 3f 5 interp ; 276 | 277 | 0 mv gives 0 278 | 128 mv gives 900 279 | 256 mv gives 1800 280 | and intermediate values are interpolated.") 281 | 282 | (rom-doc 283 | "triangle" 1394 284 | "triangle assuming an angle expressed as a 16 bit fraction of a 285 | revolution, 2* 2* triangle produces a triangle wave approximation 286 | to the cosine of that angle.") 287 | 288 | (rom-doc 289 | "clc" 1398 290 | "clears the carry bit for addition in extended arithmetic mode") 291 | 292 | (rom-doc 293 | "--u/mod" 1398 294 | "(TODO) 295 | the following defines u/mod in ram ... cr 296 | u/mod hld-rq - 1 . + --u/mod ; br 297 | 298 | if the divisor is a constant, just negate cr 299 | it at edit or compile time.") 300 | (rom-doc 301 | "-u/mod" 1398 302 | "(TODO)") 303 | (rom-doc 304 | "poly" 1382 305 | "poly xn-xy cr 306 | evaluation of chebyshev polynomials using the horner scheme. 307 | 308 | x is the input value. n is the length of the coefficient table minus 2. 309 | coefficient table follows inline, and execution continues after the final 310 | table entry. x is left on the stack under the result, y. 311 | 312 | for example... 313 | cos f-f' cr 314 | hart 3300 cr 315 | -0.0043 0.0794 -0.6459 0.5708 indent 316 | 2* 2* . triangle dup *. 2 poly indent 317 | -281 , 5203 , -42329 , 37407 , indent 318 | push drop pop *. + ;") 319 | 320 | (rom-doc 321 | "cold" 3141 322 | "" 323 | ": cold 3141 a! 0x3fffe dup ! rdlu cold ;") 324 | (rom-doc 325 | "ser-exec" 1422 326 | "ser-exec reads and processes a boot frame.") 327 | (rom-doc 328 | "ser-copy" 1422 329 | "ser-copy receives n words at a, nop if n zero.") 330 | (rom-doc 331 | "sget" 1422 332 | "sget receives 18 bits, first bit on falling clock edge, second bit on rising, 333 | and so on. ends with clock line high. data line must be stable by the time 334 | clock edge is seen. spins the whole time, no suspension.") 335 | 336 | (rom-doc "spi-copy" 1430 337 | "spi-copy reads one word per loop and the loop counter is the actual number of 338 | words being sent ie a count of zero means no words sent") 339 | -------------------------------------------------------------------------------- /src/sd.el: -------------------------------------------------------------------------------- 1 | (require 'cl) 2 | 3 | (defstruct sd buffer length data-length data overlays offset display-functions) 4 | ;; 1 2 3 4 5 6 7 5 | ;; because: Symbol’s function definition is void: \(setf\ sd-data-len\) 6 | (defun set-sd-data-len! (sd x) 7 | (aset sd 3 x)) 8 | (defun set-sd-data! (sd x) 9 | (aset sd 4 x)) 10 | (defun set-sd-offset! (sd x) 11 | (aset sd 6 x)) 12 | 13 | (setq sd-display-list nil) 14 | 15 | (defun sd-create (data line column length width) 16 | "creates a scroll display in the current buffer 17 | DATA - array of strings to display 18 | LINE, COLUMN - location of top left corner of display 19 | LENGTH - length of display in lines 20 | WIDTH - width of display in characters 21 | 22 | " 23 | (let* ((data-len (length data)) 24 | (overlays (make-vector length nil)) 25 | buf-lines col sd) 26 | 27 | (save-excursion 28 | (setq buf-lines (count-lines (point-min) (point-max))) 29 | (when (< buf-lines line) 30 | (end-of-buffer) 31 | (insert (make-string (- line buf-lines) ?\n))) 32 | (goto-char 0) 33 | (forward-line (1- line)) 34 | 35 | (dotimes (i length) 36 | ;;TODO: ok to have zero length overlay? 37 | (end-of-line) 38 | (setq col (current-column)) 39 | (when (< col column) ;;expand line if needed 40 | (insert (make-string (- column col) ? ))) 41 | 42 | (beginning-of-line) 43 | (forward-char column) 44 | 45 | (aset overlays i (make-overlay (point) (point))) 46 | (end-of-line) 47 | (if (eobp) 48 | (insert "\n") 49 | (forward-line)))) 50 | 51 | (setq sd (make-sd :buffer (current-buffer) 52 | :length length 53 | :data-length data-len 54 | :data data 55 | :overlays overlays 56 | :display-functions (make-vector data-len nil) 57 | :offset 0)) 58 | (push sd sd-display-list) 59 | (sd-update sd) 60 | sd)) 61 | 62 | (defun sd-update (sd) 63 | "update display overlays" 64 | (let* ((data (sd-data sd)) 65 | (offset (sd-offset sd)) 66 | (overlays (sd-overlays sd)) 67 | (fn-array (sd-display-functions sd)) 68 | fn row) 69 | (dotimes (i (sd-length sd)) 70 | (setq fn (aref fn-array i) 71 | row (aref data (+ i offset))) 72 | (when fn 73 | (setq row (funcall fn i row))) 74 | (overlay-put (aref overlays i) 'after-string row)))) 75 | 76 | (defun sd-set-data (sd data) 77 | "set the display DATA array" 78 | (assert data) 79 | (set-sd-data! sd data) 80 | (let ((data-len (length data)) 81 | (offset (sd-offset sd))) 82 | (set-sd-data-len! sd data-len) 83 | (set-sd-offset! sd (max (min offset (- data-len (sd-length sd))) 0))) 84 | (sd-update sd)) 85 | 86 | (defun sd-move-to_ (sd curr new) 87 | (setq new (max 0 new) 88 | new (min new (- (sd-data-length sd) 89 | (sd-length sd)))) 90 | 91 | (when (not (= new curr)) 92 | (set-sd-offset! sd new) 93 | (sd-update sd))) 94 | 95 | (defun sd-move-to (sd offset) 96 | (sd-move-to_ sd (sd-offset sd) offset) 97 | (sd-update sd)) 98 | 99 | (defun sd-center-on (sd n) 100 | (sd-move-to_ sd 101 | (sd-offset sd) 102 | (- n (/ (sd-length sd) 2)))) 103 | 104 | (defun sd-move-up (sd &optional n) 105 | "scrolls the data in the display window up" 106 | (let* ((curr (sd-offset sd)) 107 | (new (+ curr (or n 1)))) 108 | (sd-move-to_ sd curr new))) 109 | 110 | (defun sd-move-down (sd &optional n) 111 | "scrolls the data in the display window down" 112 | (sd-move-up sd (- (or n 1)))) 113 | 114 | (defun sd-remove (sd) 115 | "remove a scroll display from its buffer" 116 | (mapc (lambda (o) 117 | (delete-overlay o)) 118 | (sd-overlays sd)) 119 | (setq sd-display-list (remove sd sd-display-list))) 120 | 121 | (defun sd-set-display-function (sd line function) 122 | ;;FUNCTION accepts two args: 'line' and 'data'. 123 | ;; 'index' is the line of the display being updated 124 | ;; 'data' is the data that is to be displayed on that line 125 | ;; the function must return a string, which would replace 'data' on the display 126 | ;; by default function is the identity function 127 | (let ((fn-array (sd-display-functions sd))) 128 | (assert (and (>= line 0) (<= line (sd-length sd)))) 129 | (aset fn-array line function))) 130 | 131 | (defun sd-delete-all () 132 | "global cleanup off all displays" 133 | (mapc 'sd-remove sd-display-list) 134 | (setq sd-display-list nil)) 135 | 136 | (defun sd-realign () 137 | "redraw the sd if the overlays have been moved horizontally" 138 | (error "sd-realign unimplemented")) 139 | 140 | (provide 'sd) 141 | -------------------------------------------------------------------------------- /src/stack.rkt: -------------------------------------------------------------------------------- 1 | #lang racket ;; -*- lexical-binding: t -*- 2 | ;;; Some utilities for working with 8-word circular stacks 3 | 4 | (require "el.rkt") 5 | 6 | (provide (all-defined-out)) 7 | 8 | (struct stack (sp body) #:mutable #:transparent) 9 | 10 | (define (make-stack len (init 0)) 11 | (stack 0 (make-vector len init))) 12 | 13 | ;;; Copies the given stack. This keeps mutable vectors from being 14 | ;;; shared between different stacks. 15 | (define (copy-stack s) 16 | (stack (stack-sp s) (vector-copy (stack-body s)))) 17 | 18 | ;;; Print a circular stack: 19 | (define (display-stack stack) 20 | (for ((i (in-range 0 8))) 21 | (printf " ~x" (vector-ref (stack-body stack) 22 | (modulo (- (stack-sp stack) i) 8))))) 23 | 24 | ;;; Pushes a value to the given stack's body. 25 | (define (push-stack! stack value) 26 | (set-stack-sp! stack (modulo (add1 (stack-sp stack)) 8)) 27 | (vector-set! (stack-body stack) (stack-sp stack) value)) 28 | 29 | ;;; Pops from the given stack's body. 30 | (define (pop-stack! stack) 31 | (let ((ret-val (vector-ref (stack-body stack) (stack-sp stack)))) 32 | (set-stack-sp! stack (modulo (sub1 (stack-sp stack)) 8)) 33 | ret-val)) 34 | 35 | ;;; Returns a stack with randomized entries, each less than max-size. 36 | (define (random-stack (max-size #x40000)) 37 | (stack 0 (vector-map! (lambda (_) (random max-size)) (make-vector 8)))) 38 | 39 | (define (stack->list stack) 40 | (let* ((len (vector-length (stack-body stack))) 41 | (stack-v (stack-body stack)) 42 | (sp (stack-sp stack))) 43 | (for/list ((i len)) 44 | (vector-ref stack-v (modulo (- sp i) 8))))) 45 | 46 | (define (stack->vector stack) 47 | (stack->vector (vector->list stack))) 48 | -------------------------------------------------------------------------------- /tests/ga-benchmark.el: -------------------------------------------------------------------------------- 1 | ;; -*- lexical-binding: t -*- 2 | 3 | (setq chip (ga144-new "test-chip")) 4 | (setq steps 1000000) 5 | 6 | (setq code-fmt " 7 | node %s 8 | : fn2 ; 9 | : fn &fn2 push ex dup +* 4 for + unext or if 2/ then 2/ - 0 a! 3 for @ next fn2 ; 10 | : main 12334 42212 fn 2* -if 2* then and or dup drop pop over a io b! @b !b 0 a! a 2* main 11 | ") 12 | 13 | ;; test single node execution speed 14 | 15 | (setq code (format code-fmt "1")) 16 | (setq assembled (assemble (aforth-compile code))) 17 | (setq start-time (current-time)) 18 | (send chip load assembled) 19 | (setq node1 (send chip coord->node 1)) 20 | (send node1 set-break-at-step steps) 21 | (send chip step-program!*) 22 | ;;(send node1 print-inst-counters) 23 | (message "single node execution (%s steps): %s\n" steps (float-time (time-since start-time))) 24 | 25 | 26 | ;; test all nodes 27 | 28 | (setq chip (ga144-new "test-chip")) 29 | (setq code (mapconcat (lambda (x) (format code-fmt (index->coord x))) (number-sequence 0 143) "\n")) 30 | (setq assembled (assemble (aforth-compile code))) 31 | (setq start-time (current-time)) 32 | (setq node-steps (floor (/ steps 144))) 33 | (send chip load assembled) 34 | (dotimes (i 144) 35 | (send (send chip coord->node (index->coord i)) set-break-at-step node-steps)) 36 | (send chip step-program!*) 37 | (message "all node execution (%s steps): %s\n" node-steps (float-time (time-since start-time))) 38 | 39 | 40 | ;; test boostream 41 | 42 | (defun test-bootstream() 43 | (ga144-clear-all) 44 | (setq host (ga144-new "host")) 45 | (setq target (ga144-new "target")) 46 | (setq code " 47 | node 708 48 | 11 22 + 49 | ") 50 | 51 | (setq assembled (assemble (aforth-compile code))) 52 | ;;(define bootstream (make-sync-bootstream (compiled-nodes assembled))) 53 | (setq bs (make-bootstream assembled "async-target")) 54 | (ga144-connect-pins (ga144-get-node host 300) 0 55 | (ga144-get-node target 300) 0) 56 | (ga144-connect-pins (ga144-get-node host 300) 1 57 | (ga144-get-node target 300) 1) 58 | 59 | (ga144-step*) 60 | 61 | (send host load-bootstream bs) 62 | 63 | (ga144-step*) 64 | 65 | (setq node708 (send target coord->node 708)) 66 | (setq memory (send node708 get-memory)) 67 | (setq dstack (send node708 get-dstack-as-list)) 68 | (assert (= (vector-ref memory 1) 11)) 69 | (assert (= (vector-ref memory 2) 22)) 70 | ) 71 | 72 | (setq start-time (current-time)) 73 | (setq bootstream-iters 1) 74 | (dotimes (i bootstream-iters) 75 | (test-bootstream) 76 | (message "testing bootstream")) 77 | (message "bootstream test (%s times): %s\n" bootstream-iters (float-time (time-since start-time))) 78 | 79 | 80 | ;; test compile time 81 | (setq code (mapconcat (lambda (x) (format code-fmt (index->coord x))) (number-sequence 0 143) "\n")) 82 | (setq iters 50) 83 | (setq start-time (current-time)) 84 | (dotimes (i iters) 85 | (assemble (aforth-compile code))) 86 | (message "compile/assemble test (%s iters): %s\n" iters (float-time (time-since start-time))) 87 | 88 | ;; test initialization time 89 | (setq code (mapconcat (lambda (x) (format code-fmt (index->coord x))) (number-sequence 0 143) "\n")) 90 | (setq init-iters 50) 91 | (setq assembled (assemble (aforth-compile code))) 92 | (setq start-time (current-time)) 93 | 94 | (dotimes (i iters) 95 | (setq chip (ga144-new "test-chip")) 96 | (send chip load assembled)) 97 | 98 | (message "init test (%s iters): %s\n" init-iters (float-time (time-since start-time))) 99 | 100 | -------------------------------------------------------------------------------- /tests/ga-test-pins.el: -------------------------------------------------------------------------------- 1 | ;; tests pin callbacks and breakpoints 2 | 3 | (define-test-fn "test-pins" 4 | (lambda () 5 | (setq host (ga144-new "host")) 6 | 7 | (setq code "node 705 8 | : aa 0 !b ; 9 | : bb ; 10 | : main 11 | io b! 12 | 0x3ffff !b 13 | aa bb 14 | warm 15 | ") 16 | 17 | (setq compiled (aforth-compile code)) 18 | (setq assembled (assemble compiled)) 19 | 20 | (setq node (ga144-get-node host 705)) 21 | 22 | (setq pin0-config nil) 23 | (setq pin1-config nil) 24 | (setq pin2-config nil) 25 | (setq pin3-config nil) 26 | 27 | (send node set-gpio-handlers 28 | (lambda (x) (message "pin0: %s" x) 29 | (setq pin0-config x)) 30 | (lambda (x) (setq pin1-config x)) 31 | (lambda (x) (setq pin2-config x)) 32 | (lambda (x) (setq pin3-config x))) 33 | 34 | ;;code must be loaded before named breakpoints can be set 35 | (send host load assembled) 36 | (send node set-breakpoint "aa") 37 | (send node set-breakpoint "bb") 38 | 39 | (ga144-step*) 40 | ;;(send node describe-io) 41 | (setq ok (check 3 3 3 3)) 42 | (ga144-step*) 43 | ;;(send node describe-io) 44 | (and (check 0 0 0 0) ok) 45 | )) 46 | 47 | (defun printer (pin) 48 | (lambda (val) (printf "pin ~a: ~a\n" pin val))) 49 | 50 | (defun report (pin expect actual) 51 | (message "pin %s has value %s, expected %s" pin actual expect)) 52 | 53 | (defun check (a b c d) 54 | (let ((ok t)) 55 | (unless (eq a pin0-config) 56 | (report 0 a pin0-config) 57 | (setq ok nil)) 58 | (unless (eq b pin1-config) 59 | (report 1 b pin1-config) 60 | (setq ok nil)) 61 | (unless (eq c pin2-config) 62 | (report 2 c pin2-config) 63 | (setq ok nil)) 64 | (unless (eq d pin3-config) 65 | (report 3 d pin3-config) 66 | (setq ok nil)) 67 | ok)) 68 | 69 | (provide 'ga-test-pins) 70 | -------------------------------------------------------------------------------- /tests/ga-test-target-chip.el: -------------------------------------------------------------------------------- 1 | ;; -*- lexical-binding: t -*- 2 | 3 | ;; tests loading a program into the target chip through node 300 4 | ;; using the 2-wire connection. 5 | ;; The host and target chip are connected with virtual wires. 6 | ;; [[ currently requires changes in function load-bootstream in f18a.rkt to load 7 | ;; bootstream from 708 instead of 300 ]] 8 | ;; The normal async bootstream is loaded into the host chip, that loads code 9 | ;; that carries the sync bootstream from node host.708 to host.300 where it is sent 10 | ;; over 2-wire to target.300, loading code for the target chip. 11 | 12 | (define-test-fn "target chip" 13 | (lambda () 14 | (setq host (ga144-new "host")) 15 | (setq target (ga144-new "target")) 16 | 17 | (setq code " 18 | node 708 19 | 11 22 + 20 | ") 21 | 22 | (setq assembled (assemble (aforth-compile code))) 23 | ;;(define bootstream (make-sync-bootstream (compiled-nodes assembled))) 24 | (setq bs (make-bootstream assembled "async-target")) 25 | (ga144-connect-pins (ga144-get-node host 300) 0 26 | (ga144-get-node target 300) 0) 27 | (ga144-connect-pins (ga144-get-node host 300) 1 28 | (ga144-get-node target 300) 1) 29 | 30 | (ga144-step*) 31 | 32 | (send host load-bootstream bs) 33 | 34 | (ga144-step*) 35 | 36 | (setq node708 (send target coord->node 708)) 37 | (setq memory (send node708 get-memory)) 38 | (setq dstack (send node708 get-dstack-as-list)) 39 | (assert (= (vector-ref memory 1) 11)) 40 | (assert (= (vector-ref memory 2) 22)) 41 | 42 | 43 | (assert (= (car dstack) 33)) 44 | (assert (= (cadr dstack) #x15555)) 45 | ;;(message "instruction count:\n") 46 | ;;(send node708 print-inst-counters) 47 | t)) 48 | 49 | 50 | (provide 'ga-test-target-chip) 51 | -------------------------------------------------------------------------------- /tests/test-breakpoints.rkt: -------------------------------------------------------------------------------- 1 | #lang racket ;; -*- lexical-binding: t -*- 2 | 3 | (require compatibility/defmacro 4 | "../interpreter.rkt" 5 | "../compile.rkt" 6 | "../assemble.rkt" 7 | "../bootstream.rkt" 8 | "../stack.rkt") 9 | 10 | (define chip (new-ga144 "host")) 11 | 12 | 13 | (define loop-count 10) 14 | (define code (rkt-format "node 705 15 | , 444 16 | , 555 17 | , 666 18 | 19 | : main 20 | 21 | io b! 22 | 0x3ffff !b 23 | 1 3 add 24 | 4 double 25 | ~a fn 26 | 0 if 27 | : add + ; 28 | : double dup + ; 29 | : inc 1 + ; 30 | : fn for inc next ; 31 | then 32 | " loop-count)) 33 | 34 | (define compiled (aforth-compile code)) 35 | (define assembled (assemble compiled)) 36 | 37 | (define node (get-node chip 705)) 38 | 39 | (send chip load assembled) 40 | (send node set-breakpoint "add") 41 | (send node set-breakpoint "double") 42 | (define inc-counter 0) 43 | (send node set-word-hook-fn 44 | "inc" 45 | (lambda () (set! inc-counter (add1 inc-counter)))) 46 | 47 | (enter-cli-on-breakpoint t) 48 | (step*) ;;step to add 49 | (step*) ;;step to double 50 | (step*) ;;finish program 51 | 52 | (unless (equal? inc-counter (add1 loop-count)) 53 | (raise (rkt-format "check failed: ~a == ~a" inc-counter (add1 loop-count)))) 54 | 55 | 56 | -------------------------------------------------------------------------------- /tests/test-compiler.rkt: -------------------------------------------------------------------------------- 1 | #lang racket ;; -*- lexical-binding: t -*- 2 | 3 | (require compatibility/defmacro 4 | "../src/common.rkt" 5 | "../src/compile.rkt" 6 | "../src/assemble.rkt" 7 | "../src/el.rkt") 8 | 9 | (define compiler-tests 10 | '(("node 1 " (1 )) 11 | ("node 1 2" (1 ("@p" "." "." ".") 12 | 2)) 13 | ("node 1 22 +" (1 ("@p" "+" "." ".") 14 | 22)) 15 | ("node 1 @ @ @ @ @ @" (1 ("@" "@" "@" ".") 16 | ("@" "@" "@" "."))) 17 | ("node 1 dup dup dup dup @p @p @p @p" (1 ("dup" "dup" "dup" "dup") 18 | ("@p" "@p" "@p" "@p"))) 19 | ("node 1 0 if dup dup then over over" (1 ("@p" "if" 3 ".") 20 | 0 21 | ("dup" "dup" "." ".") 22 | ("over" "over" "." "."))) 23 | ("node 1 up down left right" (1 ("@p" "@p" "@p" "@p") 325 277 373 469)) 24 | ("node 2 up down left right" (2 ("@p" "@p" "@p" "@p") 325 277 373 469)) 25 | ("node 101 up down left right" (101 ("@p" "@p" "@p" "@p") 325 277 373 469)) 26 | ("node 1 north east south west" (1 ("@p" "@p" "@p" "@p") 27 | 277 373 325 469)) 28 | ("node 2 north east south west" (2 ("@p" "@p" "@p" "@p") 29 | 277 469 325 373)) 30 | ("node 101 north east south west" (101 ("@p" "@p" "@p" "@p") 31 | 325 373 277 469)) 32 | ("node 102 north east south west" (102 ("@p" "@p" "@p" "@p") 33 | 325 469 277 373)) 34 | ("node 1 : word dup ; : word2 + + + ; word word2" (1 ("dup" ";" "." ".") 35 | ("+" "+" "+" ";") 36 | ("call" 0 "." ".") 37 | ("call" 1 "." "."))) 38 | ("node 1 ---u --l- --lu -d--" (1 ("call" 325 "." ".") 39 | ("call" 373 "." ".") 40 | ("call" 357 "." ".") 41 | ("call" 277 "." "."))) 42 | ("node 1 100 0x100 0b101" (1 ("@p" "@p" "@p" ".") 100 256 5)) 43 | ("node 1 + ( comment ) (comment) + \\comment" (1 ("+" "+" "." "."))) 44 | ("node 1 + .. + . + .. ." (1 ("+" "." "." ".") 45 | ("+" "." "+" ".") 46 | ("." "." "." "."))) 47 | ("node 1 1 , 2 3" (1 ("@p" "@p" "." ".") 48 | 1 2 3)) 49 | ("node 1 0 2 + + here 5 next" (1 ("@p" "@p" "+" "+") 50 | 0 2 51 | ("@p" "next" 3 ".") 5)) 52 | ("node 1 3 for 2/ next + + 3 for dup dup dup dup dup next" (1 ("@p" "push" "." ".") 53 | 3 54 | ("2/" "next" 2 ".") 55 | ("+" "+" "@p" ".") 56 | 3 57 | ("push" "." "." ".") 58 | ("dup" "dup" "dup" "dup") 59 | ("dup" "next" 6 "."))) 60 | ("node 1 3 for 2* unext" (1 ("@p" "push" "." ".") 61 | 3 62 | ("2*" "unext" "." "."))) 63 | ("node 1 0 if dup then +" (1 ("@p" "if" 3 ".") 64 | 0 65 | ("dup" "." "." ".") 66 | ("+" "." "." "."))) 67 | ("node 1 0 -if dup then +" (1 ("@p" "-if" 3 ".") 68 | 0 69 | ("dup" "." "." ".") 70 | ("+" "." "." "."))) 71 | ("node 1 :: aaa dup 1 + + lit ; :: bbb 5 aaa ; + bbb +" (1 ("+" "@p" "+" ".") 72 | 11)) 73 | ("node 1 :: five 5 lit ; five five" (1 ("@p" "@p" "." ".") 74 | 5 5)) 75 | ("node 1 warm node 5 warm node 104 warm ; " 76 | (1 ("call" 169 "." ".")) 77 | (5 ("call" 169 "." ".")) 78 | (104 ("jump" 169 "." "."))) 79 | ("node 0 +" (0 ( "+" "." "." "."))) 80 | ("node 1 org 0 +" (1 ( "+" "." "." "."))) 81 | ("node 1 0 " (1 ( "@p" "." "." ".") 82 | 0)) 83 | ("node 1 :: zero 0 lit ; zero " (1 ( "@p" "." "." ".") 84 | 0)) 85 | ("node 1 : min - over . + - -if + ; then drop ; : max - over . + - -if drop ; then + ;" 86 | (1 ("-" "over" "." "+") 87 | ("-" "-if" 3 ".") 88 | ("+" ";" "." ".") 89 | ("drop" ";" "." ".") 90 | ("-" "over" "." "+") 91 | ("-" "-if" 7 ".") 92 | ("drop" ";" "." ".") 93 | ("+" ";" "." "."))) 94 | 95 | ("node 1 : A + ; : B dup ; : C 2/ ; &A &B &C" (1 ("+" ";" "." ".") 96 | ("dup" ";" "." ".") 97 | ("2/" ";" "." ".") 98 | ("@p" "@p" "@p" ".") 99 | 0 1 2)) 100 | ;;("node 1 : A + ; B@100 node 100 B over ; A@1" (1 ) (100 )) 101 | ("node 1 dup : A + ; node 100 : B over ; A@1" 102 | (1 ("dup" "." "." ".") 103 | ("+" ";" "." ".")) 104 | (100 ("over" ";" "." ".") 105 | ("call" 1 "." "."))) 106 | ("node 1 dup : A + ; node 100 : B over ; &A@1" 107 | (1 ("dup" "." "." ".") 108 | ("+" ";" "." ".")) 109 | (100 ("over" ";" "." ".") 110 | ("@p" "." "." ".") 111 | 1)) 112 | 113 | ;; test instruction shifting 114 | ("node 500 . . if .. . : word1 1 ; word then : word word1 ;" 115 | (500 ("." "." "if" 5) 116 | ("." "." "." ".") 117 | ("@p" ";" "." ".") 118 | 1 119 | ("call" 5 "." ".") 120 | ("jump" 2 "." "."))) 121 | ("node 500 . . if .. . .. . .. . .. . : word1 1 ; word then : word word1 ;" 122 | (500 ("." "." "." ".") 123 | ("if" 9 "." ".") 124 | ("." "." "." ".") 125 | ("." "." "." ".") 126 | ("." "." "." ".") 127 | ("." "." "." ".") 128 | ("@p" ";" "." ".") 129 | 1 130 | ("call" 9 "." ".") 131 | ("jump" 6 "." "."))) 132 | 133 | ;; test if: and next: 134 | ("node 0 . : word1 ; if: word2 if: word1 : word2 ;" 135 | (0 ("." "." "." ".") 136 | (";" "." "." ".") 137 | ("if" 4 "." ".") 138 | ("if" 1 "." ".") 139 | (";" "." "." "."))) 140 | ("node 1 . : word1 ; next: word2 next: word1 : word2 ;" 141 | (1 ("." "." "." ".") 142 | (";" "." "." ".") 143 | ("next" 4 "." ".") 144 | ("next" 1 "." ".") 145 | (";" "." "." "."))) 146 | 147 | ("node 1 dup + + + include __test.aforth over " 148 | (1 ("dup" "+" "+" "+") 149 | ("@p" "." "." ".") 150 | ("+" ";" "." ".") 151 | ("jump" 2 "." ".") 152 | ("-" "over" "." "."))) 153 | 154 | 155 | ;; test double shifting 156 | ("node 205 157 | : main 158 | 159 | : update 160 | 2* 161 | 0x20003 or drop 162 | .. @p ! 163 | .. @+ !p unext .. 164 | .. 2/ push 165 | begin @ push @ pop next .. 166 | @p ! 167 | .. @p a! ; .. 168 | 169 | pop ! done 170 | 171 | .. . .. 172 | 173 | : focus 174 | .. . .. 175 | .. . .. 176 | .. . .. 177 | .. @p @p @p @p .. 178 | 179 | . + last 180 | ; 181 | : done 182 | @p ! 183 | .. ; .. 184 | ; 185 | .. . 186 | .. . 187 | .. . 188 | 189 | : last 190 | ." 191 | (205 192 | ("2*" "@p" "or" ".") 193 | 131075 194 | ("drop" "." "." ".") 195 | ("@p" "!" "." ".") 196 | ("@+" "!p" "unext" ".") 197 | ("2/" "push" "." ".") 198 | ("@" "push" "@" ".") 199 | ("pop" "next" 6 ".") 200 | ("@p" "!" "." ".") 201 | ("@p" "a!" ";" ".") 202 | ("pop" "!" "." ".") 203 | ("call" 19 "." ".") 204 | ("." "." "." ".") 205 | ("." "." "." ".") 206 | ("." "." "." ".") 207 | ("." "." "." ".") 208 | ("@p" "@p" "@p" "@p") 209 | ("." "+" "." ".") 210 | ("jump" 25 "." ".") 211 | ("@p" "!" "." ".") 212 | (";" "." "." ".") 213 | (";" "." "." ".") 214 | ("." "." "." ".") 215 | ("." "." "." ".") 216 | ("." "." "." ".") 217 | ("." "." "." "."))) 218 | )) 219 | 220 | 221 | (define (fix-word word) 222 | (when (vector? word) 223 | (set! word (vector->list word))) 224 | 225 | (if (list? word) 226 | (map (lambda (x) (if (equal? x false) "." x)) 227 | word) 228 | word)) 229 | 230 | (define (trim-mem mem) 231 | (map fix-word 232 | (filter (lambda (x) (not (or (equal? x (vector false false false false)) 233 | (equal? x false)))) 234 | (vector->list mem)))) 235 | 236 | (define (run-compiler-tests) 237 | (define code false) 238 | (define compiled false) 239 | (define compiled-hash false) 240 | (define node false) 241 | (define expect false) 242 | (define mem false) 243 | (define ok true) 244 | (for ((test compiler-tests)) 245 | (set! code (car test)) 246 | (printf "testing: ~a\n" (replace-regexp-in-string "\n" " " code)) 247 | (assert (string? code)) 248 | (set! compiled (aforth-compile code)) 249 | (set! compiled-hash (make-hash)) 250 | (if (not (compiled-nodes compiled)) 251 | (begin (if elisp? 252 | (aforth-print-error-data compiled) 253 | (printf "compilation failure")) 254 | (set! ok false)) 255 | (begin 256 | (for ((node (compiled-nodes compiled))) 257 | (hash-set! compiled-hash (node-coord node) 258 | (trim-mem (vector-copy (node-mem node))))) 259 | (for ((x (cdr test))) 260 | (set! node (car x)) 261 | (set! expect (cdr x)) 262 | (if (hash-has-key? compiled-hash node) 263 | (set! mem (hash-ref compiled-hash node)) 264 | (error (rkt-format "Expected node '~a' results from test code \"~a\"\n" node code))) 265 | (when (not (equal? mem expect)) 266 | (printf "failed: '~a'\n" code) 267 | (printf " got: ~a\n" mem) 268 | (printf "expected: ~a\n\n" expect) 269 | (set! ok false)))))) 270 | ;;(printf "ran ~a tests\n" (length compiler-tests)) 271 | ok) 272 | 273 | (unless elisp? 274 | (printf "running compiler checks...\n") 275 | (printf "~a\n" (if (run-compiler-tests) "ok" "failed"))) 276 | -------------------------------------------------------------------------------- /tests/test-hmm.rkt: -------------------------------------------------------------------------------- 1 | #lang racket ;; -*- lexical-binding: t -*- 2 | 3 | (require compatibility/defmacro 4 | "../src/interpreter.rkt" 5 | "../src/compile.rkt" 6 | "../src/assemble.rkt" 7 | "../src/bootstream.rkt" 8 | "../src/stack.rkt" 9 | "../src/el.rkt") 10 | 11 | (define chip (new-ga144 "host")) 12 | 13 | ;; compile and assemble code 14 | (define compiled (aforth-compile (file->string "hmm_pinning_real-noopt3.aforth"))) 15 | (define assembled (assemble compiled)) 16 | 17 | ;; load assembled code into chip 18 | (send chip load assembled) 19 | 20 | ;; set breakpoint at word 'two' in node 305 21 | (define node_305 (get-node chip 305)) 22 | ;(send node_305 set-breakpoint "one") 23 | (send node_305 set-breakpoint "two") 24 | 25 | ;; entering the cli is optional and must be enabled 26 | (enter-cli-on-breakpoint t) 27 | 28 | ;; prints a representation of every nodes io state at each change 29 | ;(send chip show-io-changes t) 30 | 31 | ;; step* runs the interpreter until it exits or a breakpoint is reached 32 | (step*) 33 | (step*) 34 | (step*) 35 | (step*) 36 | (step*) 37 | (step*) 38 | 39 | ;(enter-cli) 40 | -------------------------------------------------------------------------------- /tests/test-target-chip.rkt: -------------------------------------------------------------------------------- 1 | #lang racket ;; -*- lexical-binding: t -*- 2 | 3 | ;; tests loading a program with into the target chip through node 300 4 | ;; using the 2-wire connection. 5 | ;; [[ currently requires changes in function load-bootstream in f18a.rkt to load 6 | ;; bootstream from 708 instead of 300 ]] 7 | ;; The normal async bootstream is used to load code into the host chip that 8 | ;; carries teh bootstream from node 708 to 300 where it is sent 9 | ;; The normal async bootstream is loaded into the host chip, that loads code 10 | ;; that carries the sync bootstream from node 708 to 300 where it is sent 11 | ;; over 2-wire to the target chip, loading code for the target chip. 12 | 13 | (require compatibility/defmacro 14 | "../src/common.rkt" 15 | "../src/interpreter.rkt" 16 | "../src/compile.rkt" 17 | "../src/assemble.rkt" 18 | "../src/bootstream.rkt" 19 | "../src/stack.rkt" 20 | "../src/el.rkt") 21 | 22 | (define host (new-ga144 "host")) 23 | (define target (new-ga144 "target")) 24 | 25 | (define code " 26 | node 708 27 | 11 22 + 28 | ") 29 | 30 | (define assembled (assemble (aforth-compile code))) 31 | ;;(define bootstream (make-sync-bootstream (compiled-nodes assembled))) 32 | (define bs (make-bootstream assembled "async-target")) 33 | (connect-pins (get-node host 300) 0 34 | (get-node target 300) 0) 35 | (connect-pins (get-node host 300) 1 36 | (get-node target 300) 1) 37 | 38 | ;;(enter-cli) 39 | (step*) 40 | (send host load-bootstream bs) 41 | ;;(enter-cli) 42 | 43 | (step*) 44 | 45 | (define node708 (send target coord->node 708)) 46 | (define memory (send node708 get-memory)) 47 | (assert (= (vector-ref memory 1) 11)) 48 | (assert (= (vector-ref memory 2) 22)) 49 | 50 | (define dstack (send node708 get-dstack-as-list)) 51 | (assert (= (car dstack) 33)) 52 | (assert (= (cadr dstack) #x15555)) 53 | -------------------------------------------------------------------------------- /tests/test-word-hook.rkt: -------------------------------------------------------------------------------- 1 | #lang racket ;; -*- lexical-binding: t -*- 2 | 3 | (require compatibility/defmacro 4 | "../interpreter.rkt" 5 | "../compile.rkt" 6 | "../assemble.rkt" 7 | "../bootstream.rkt" 8 | "../stack.rkt") 9 | 10 | (define chip (new-ga144 "host")) 11 | 12 | (define code "node 705 13 | 0 if 14 | : b dup + ; 15 | : a for b next ; 16 | : c 10 a ; 17 | then 18 | ") 19 | 20 | (define compiled (aforth-compile code)) 21 | (define assembled (assemble compiled)) 22 | 23 | (define node (get-node chip 705)) 24 | 25 | (send chip load assembled) 26 | 27 | (define b-counter 0) 28 | (send node set-word-hook-fn 29 | "b" 30 | (lambda () (set! b-counter (add1 b-counter))) 31 | ) 32 | 33 | (enter-cli-on-breakpoint t) 34 | 35 | (step*) 36 | (define loop-count 15) 37 | (send node d-push! loop-count) 38 | (send node call-word! "a") 39 | (step*) 40 | (printf "b-counter = ~a\n" b-counter) 41 | 42 | (unless (equal? b-counter (add1 loop-count)) 43 | (raise (rkt-format "check failed: ~a == ~a" b-counter (add1 loop-count)))) 44 | -------------------------------------------------------------------------------- /variables.aforth: -------------------------------------------------------------------------------- 1 | node 1 2 | : x! @p drop !p ; 3 | : x 0 ; 4 | : main 5 | 5 x! ( set 6 | x ( reference 7 | 8 | --------------------------------------------------------------------------------