f797a21c8c 2010-08-18 charlesch: ( Copyright [c] 2010, Charles Childers ) f797a21c8c 2010-08-18 charlesch: ( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ) f797a21c8c 2010-08-18 charlesch: 90c0b418f9 2010-12-20 charlesch: global with console' with extras' f797a21c8c 2010-08-18 charlesch: f797a21c8c 2010-08-18 charlesch: {{ f797a21c8c 2010-08-18 charlesch: ( Helpers to make the code easier to read ~~~~~~~~~~~~~~~~~ ) f797a21c8c 2010-08-18 charlesch: : case: ( nn- ) ` over ` =if ` space ; immediate 90c0b418f9 2010-12-20 charlesch: : ;case ( nn-n ) ` nip ` ;; ` then ; immediate f797a21c8c 2010-08-18 charlesch: f797a21c8c 2010-08-18 charlesch: ( Resolve addresses to headers ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ) f797a21c8c 2010-08-18 charlesch: : header? ( a-af ) dup xt->d ; f797a21c8c 2010-08-18 charlesch: : xt->name ( a-$ ) xt->d d->name ; e091b5413a 2010-09-20 charlesch: : .name ( a- ) xt->name puts space ; 90c0b418f9 2010-12-20 charlesch: : <call> ( n- ) red "<call " puts putn '> putc space ; e091b5413a 2010-09-20 charlesch: : resolve ( n- ) header? if .name ;then <call> ; 90c0b418f9 2010-12-20 charlesch: : (name) ( a- ) yellow '( putc space .name ') putc space ; e091b5413a 2010-09-20 charlesch: : (resolve) ( n- ) header? if red dup putn space (name) ;then red putn space ; f797a21c8c 2010-08-18 charlesch: f797a21c8c 2010-08-18 charlesch: : instr? ( n-f ) e091b5413a 2010-09-20 charlesch: 0 case: "nop" puts 0 ;case e091b5413a 2010-09-20 charlesch: 1 case: "lit" puts -1 ;case e091b5413a 2010-09-20 charlesch: 2 case: "dup" puts 0 ;case e091b5413a 2010-09-20 charlesch: 3 case: "drop" puts 0 ;case e091b5413a 2010-09-20 charlesch: 4 case: "swap" puts 0 ;case e091b5413a 2010-09-20 charlesch: 5 case: "push" puts 0 ;case e091b5413a 2010-09-20 charlesch: 6 case: "pop" puts 0 ;case e091b5413a 2010-09-20 charlesch: 7 case: "call" puts -1 ;case e091b5413a 2010-09-20 charlesch: 8 case: "jump" puts -1 ;case e091b5413a 2010-09-20 charlesch: 9 case: ";" puts 0 ;case e091b5413a 2010-09-20 charlesch: 10 case: ">jump" puts -1 ;case e091b5413a 2010-09-20 charlesch: 11 case: "<jump" puts -1 ;case e091b5413a 2010-09-20 charlesch: 12 case: "!jump" puts -1 ;case e091b5413a 2010-09-20 charlesch: 13 case: "=jump" puts -1 ;case e091b5413a 2010-09-20 charlesch: 14 case: "@" puts 0 ;case e091b5413a 2010-09-20 charlesch: 15 case: "!" puts 0 ;case e091b5413a 2010-09-20 charlesch: 16 case: "+" puts 0 ;case e091b5413a 2010-09-20 charlesch: 17 case: "-" puts 0 ;case e091b5413a 2010-09-20 charlesch: 18 case: "*" puts 0 ;case e091b5413a 2010-09-20 charlesch: 19 case: "/mod" puts 0 ;case e091b5413a 2010-09-20 charlesch: 20 case: "and" puts 0 ;case e091b5413a 2010-09-20 charlesch: 21 case: "or" puts 0 ;case e091b5413a 2010-09-20 charlesch: 22 case: "xor" puts 0 ;case e091b5413a 2010-09-20 charlesch: 23 case: "<<" puts 0 ;case e091b5413a 2010-09-20 charlesch: 24 case: ">>" puts 0 ;case e091b5413a 2010-09-20 charlesch: 25 case: "0;" puts 0 ;case e091b5413a 2010-09-20 charlesch: 26 case: "1+" puts 0 ;case e091b5413a 2010-09-20 charlesch: 27 case: "1-" puts 0 ;case e091b5413a 2010-09-20 charlesch: 28 case: "in" puts 0 ;case e091b5413a 2010-09-20 charlesch: 29 case: "out" puts 0 ;case e091b5413a 2010-09-20 charlesch: 30 case: "wait" puts 0 ;case f797a21c8c 2010-08-18 charlesch: space resolve 0 ; f797a21c8c 2010-08-18 charlesch: f797a21c8c 2010-08-18 charlesch: : end? ( a-a || a- ) f797a21c8c 2010-08-18 charlesch: ( First, see if we have a ; followed by a header ~~~~~~~~~~ ) f797a21c8c 2010-08-18 charlesch: dup 1- @+ 9 =if @ 30 >if pop 2drop ;then ;then drop f797a21c8c 2010-08-18 charlesch: ( Otherwise, look for two nop's in a row ~~~~~~~~~~~~~~~~~~ ) f797a21c8c 2010-08-18 charlesch: dup @+ 0 =if @+ 0 =if pop 2drop else drop ;then drop ;then f797a21c8c 2010-08-18 charlesch: ( Neither? Discard the address ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ) f797a21c8c 2010-08-18 charlesch: drop ; e091b5413a 2010-09-20 charlesch: : row ( a-a ) e091b5413a 2010-09-20 charlesch: cyan dup putn space @+ instr? if @+ space (resolve) then cr ; e091b5413a 2010-09-20 charlesch: : decompile ( a- ) repeat row end? again ; f797a21c8c 2010-08-18 charlesch: f797a21c8c 2010-08-18 charlesch: ( Interactive browsing of memory ~~~~~~~~~~~~~~~~~~~~~~~~~~ ) f797a21c8c 2010-08-18 charlesch: variable x 90c0b418f9 2010-12-20 charlesch: : rows @ch 2 - ; f797a21c8c 2010-08-18 charlesch: : handle f797a21c8c 2010-08-18 charlesch: key e091b5413a 2010-09-20 charlesch: 'i case: 1 -x drop ;then e091b5413a 2010-09-20 charlesch: 'k case: 1 +x drop ;then e091b5413a 2010-09-20 charlesch: 'j case: rows -x drop ;then e091b5413a 2010-09-20 charlesch: 'l case: rows +x drop ;then f797a21c8c 2010-08-18 charlesch: 'z case: rdrop drop ;then f797a21c8c 2010-08-18 charlesch: drop ; e091b5413a 2010-09-20 charlesch: : browse ( - ) repeat clear @x rows for row next drop handle again ; f797a21c8c 2010-08-18 charlesch: ---reveal--- e091b5413a 2010-09-20 charlesch: : see ( "- ) ' 0; cr decompile normal ; e091b5413a 2010-09-20 charlesch: : nav ( a- ) !x browse normal ; f797a21c8c 2010-08-18 charlesch: }} f797a21c8c 2010-08-18 charlesch: f797a21c8c 2010-08-18 charlesch: global