variable base 10 ;
: hex 16 base ! ;
: decimal 10 base ! ;
: octal 8 base ! ;
: 2+ 1+ 1+ ;
: c@ @ 255 and ;
: = _compare_ _=_ 1+ ;
: <> _compare_ _<>_ 1+ ;
: > _compare_ _>_ 1+ ;
: < _compare_ _<_ 1+ ;
: >= _compare_ _>=_ 1+ ;
: <= _compare_ _<=_ 1+ ;
: negate 0 swap - ;
: sp@ 0 register@ ;
: rp@ 1 register@ ;
: word-list@ 2 register@ ;
: A@ 3 register@ ;
: sp! 0 register! ;
: rp! 1 register! ;
: word-list! 2 register! ;
: A! 3 register! ;
: lshift loop 2* ;
: rshift loop 2/ ;
: tuck swap over ;
: rol >r swap r> swap ;
: ror swap >r swap r> ;
: 2drop drop drop ;
: 2dup over over ;
: 2swap >r ror ror r> swap >r rol r> swap ;
: 2over >r >r 2dup r> r> 2swap ;
: cells 2* 2* ;
: INT-MAX 1 31 lshift 1- ;
: in-range >r 1- over < swap r> 1+ < and ;
: is-print dup 32 126 in-range swap 161 255 in-range or ;
: printc dup @ emit ;
: not-at-terminator dup @ 255 and 0 <> ;
: print-sub not-at-terminator while printc 1+ not-at-terminator ;
: print print-sub drop ;
: .-to-base [char] 0 + dup [char] 9 > if 7 + ;
: .-digits loop .-to-base emit ;
: .-accumulate dup base @ 1- > while base @ /mod rol 1+ swap dup base @ 1- > ;
: .-sign dup 0< if negate [char] - emit ;
: . .-sign 0 swap .-accumulate swap 1+ .-digits ;
constant bl 32 ;
: cr 10 emit ;
: space bl emit ;
: spaces loop space ;
: dump-line-margin-dash over i 1+ - 8 = if [char] - emit space ;
: dump-line-margin-space over i 1+ - dup 4 = swap 12 = or if space ;
: dump-line-margin dump-line-margin-space dump-line-margin-dash ;
: dump-line-text 4 spaces 2dup loop dup c@ dup is-print if-else dup [char] . nip emit 1+ ;
: dump-line-hex 2dup loop space dump-line-margin dup c@ 16 /mod .-to-base emit .-to-base emit 1+ ;
: dump-line-space 16 over - dup 4 / over 8 / + spaces loop 3 spaces ;
: dump-line-header base @ >r ( hex ) over . [char] : emit r> base ! ;
: dump-line dump-line-header dump-line-hex drop dump-line-space dump-line-text drop + cr ;
: dump-whole-lines 16 /mod rol swap loop 16 dump-line ;
: dump-partial-line swap dup if dump-line zero ;
: dump dump-whole-lines dump-partial-line + ;
: d 256 dump ;
constant k_prev 0 cells ;
constant k_size 1 cells ;
constant k_type 2 cells ;
constant k_run 3 cells ;
constant k_code_size 4 cells ;
constant k_name 5 cells ;
constant k_code 13 cells ;
: get-prev dup k_prev + @ ;
: get-size dup k_size + @ ;
: get-type dup k_type + @ ;
: get-run dup k_run + @ ;
: get-code-size dup k_code_size + @ ;
: get-name dup k_name + ;
: get-code dup k_code + ;
: bottom-word word-list@ get-prev while get-prev nip get-prev ;
variable base-address bottom-word 4096 - ;
: .s-data loop space dup @ . 4 + ;
: .s-print-count dup ." <" . ." >" ;
: .s base-address @ 1024 3 * + 4 + sp@ over - 2/ 2/ 1- .s-print-count .s-data drop cr ;
: skip-string dup c@ while 1+ dup c@ ;
enum zero k_none k_generic k_if_else k_tick k_semicolon k_s_quote k_dot_quote k_comment k_char k_colon k_variable k_vector k_constant k_enum k_user_word k_user_var k_user_con k_user_vec k_enum_head k_enum_tail ;
variable dc-forward zero ;
: dc-decode-none drop zero ;
: dc-decode-primitive words-primitive print ;
: dc-decode-s_quote [char] s emit [char] " emit space 6 + dup print [char] " emit skip-string 2+ ;
: dc-test-s_quote 1+ over 0= if rol dup c@ >r ror r> 171 = if rol dup 1+ c@ >r ror r> 232 = if nip dup ;
: dc-decode-if-else ." if-else" 9 + dc-forward @ exec 2+ dc-forward @ exec ;
: dc-test-if-else 1+ over 0= if rol dup c@ >r ror r> 141 = if rol dup 3 + c@ >r ror r> 9 = if rol dup 4 + c@ >r ror r> 192 = if nip dup ;
: dc-decode-comment dup 1+ c@ swap 2+ dup [char] ( emit space print [char] ) emit + ;
: dc-test-comment 1+ over 0= if rol dup c@ >r ror r> 235 = if nip dup ;
: dc-decode-char ." [char] " dup 2+ @ emit 8 + ;
: dc-test-char 1+ over 0= if rol dup c@ >r ror r> 171 = if rol dup 1+ c@ >r ror r> 187 = if rol dup 6 + c@ >r ror r> 137 = if nip dup ;
: dc-decode-dot_quote [char] . emit [char] " emit space 24 + dup print [char] " emit skip-string 8 + ;
: dc-test-dot_quote 1+ over 0= if rol dup c@ >r ror r> 80 = if rol dup 1+ c@ >r ror r> 83 = if nip dup ;
: dc-decode-ret [char] ; emit cr drop zero ;
: dc-test-ret 1+ over 0= if rol dup c@ >r ror r> 195 = if nip dup ;
: dc-decode-call dup dup 1+ @ 5 + + k_code - get-name print drop 5 + ;
: dc-test-call 1+ over 0= if rol dup c@ >r ror r> 232 = if nip dup ;
: dc-decode-number dup 2+ @ . 7 + ;
: dc-test-number 1+ over 0= if rol dup c@ >r ror r> 171 = if rol dup 1+ c@ >r ror r> 187 = if rol dup 6 + c@ >r ror r> 147 = if nip dup ;
: dc-get-this-word word-list@ 2dup < while get-prev nip 2dup < ;
: dc-is-not-constant k_user_con over k_enum_head over k_enum_tail over = >r = >r = r> r> or or 0= nip ;
: dc-get-previous-constant get-type dc-is-not-constant while get-prev nip get-type dc-is-not-constant ;
: dc-decode-constant-find over dc-get-this-word nip dc-get-previous-constant 2dup get-code nip 2+ @ <> while get-prev nip dc-get-previous-constant 2dup get-code nip 2+ @ <> ;
: dc-decode-constant 2 + dup @ dc-decode-constant-find get-name nip print drop 1 cells + ;
: dc-test-constant 1+ over 0= if rol dup c@ >r ror r> 171 = if rol dup 1+ c@ >r ror r> 184 = if nip dup ;
: dc-is-this-not-the-variable 2dup get-size + 1 cells - <> ;
: dc-find-variable word-list@ dc-is-this-not-the-variable while get-prev nip dc-is-this-not-the-variable ;
: dc-decode-variable dup 3 + @ dup dc-find-variable get-name print 2drop drop 7 + ;
: dc-test-variable 1+ over 0= if rol dup c@ >r ror r> 171 = if rol dup 1+ c@ >r ror r> 141 = if rol dup 2 + c@ >r ror r> 5 = if nip dup ;
: dc-is-this-not-the-code 2dup get-code swap get-code-size nip + <> ;
: dc-find-word-with-code word-list@ dc-is-this-not-the-code while get-prev nip dc-is-this-not-the-code ;
: dc-decode-tick dup 3 + @ dc-find-word-with-code [char] ' emit space get-name print 2drop 7 + ;
: dc-test-tick 1+ over 0= if rol dup c@ >r ror r> 171 = if rol dup 1+ c@ >r ror r> 144 = if nip dup ;
vector dc-vector dc-decode-primitive dc-decode-ret dc-decode-call dc-decode-constant dc-decode-variable dc-decode-if-else dc-decode-s_quote dc-decode-dot_quote dc-decode-comment dc-decode-char dc-decode-number dc-decode-tick ;
: dc-test dc-test-ret dc-test-call dc-test-constant dc-test-variable dc-test-if-else dc-test-s_quote dc-test-dot_quote dc-test-comment dc-test-char dc-test-number dc-test-tick drop ;
: dc-element space zero zero dc-test dc-vector switch ;
: dc-elements dup while dc-element dup ;
: dc-definition get-code-size over get-code nip + dc-elements drop ;
: words-enum-head-body get-code swap get-code-size rol + dc-element drop space get-name print ;
: words-enum-recurse get-prev get-type k_enum_head = if-else words-enum-head-body words-enum-recurse drop space get-name print ;
: words-enum-skip get-type k_enum_head <> while get-prev nip get-type k_enum_head <> ;
: words-enum_tail ." enum" words-enum-recurse space [char] ; emit cr words-enum-skip ;
: words-enum_head ." enum" words-enum-head-body space [char] ; emit cr ;
: words-defn space get-name print dc-definition ;
: words-user-vec-loop dup @ dup while dc-element drop 1 cells - dup @ dup ;
: words-user_vec ." vector" space get-name print dup get-size + 1 cells - words-user-vec-loop 2drop space [char] ; emit cr ;
: words-user_con ." constant" words-defn ;
: words-user_var ." variable" words-defn ;
: words-user_word ." :" words-defn ;
vector words-table nop nop nop nop nop nop nop nop nop nop nop nop nop nop words-user_word words-user_var words-user_con words-user_vec words-enum_head words-enum_tail ;
: words-loop word-list@ dup while get-type words-table switch get-prev nip dup ;
: words words-loop drop ;
constant dc-initialized ' dc-element dc-forward ! 1 ;