\ Do not use this file except in compliance with the License. You may
\ obtain a copy of the License at http://www.microcore.org/MPL/
\ Software distributed under the License is distributed on an "AS IS" basis,
\ WITHOUT WARRANTY OF ANY KIND, either express or implied.
\ See the License for the specific language governing rights and limitations
\ under the License.
\
\ The Original Code is: DISASM.FS
\ 
\ Last change: KS 16.09.2015 11:39:43
\
\ The Initial Developer of the Original Code is Klaus.Schleisiek AT microcore.org.
\ Port to the gforth system and extensions by Ulrich.E.Hoffmann AT xlerb.de
\
\ MicroCore Disassembler with Macro resolution
\ DISASM displays one instruction per key pressed. <cr> or <esc> to finish
\ This code loads on the public domain Win32Forth http://www.forth.org/
\
Only Forth also definitions 

Variable Expand  Expand off  \ OFF: display macros with macro name. 
                             \ ON: display every single instruction
Variable out     out off

: dis_cr     ( -- )            out off    _CR ;
: dis_emit   ( char -- )       1 out +!   _EMIT ;
: dis_type   ( addr len -- )   dup out +! _TYPE ;
: position   ( n -- )
   out @ max BEGIN  dup out @ - WHILE  BL dis_emit  REPEAT  drop ;

: results    ( -- )   &18 position ;

: std_output ( -- )  
     [']    _CR IS CR  [']    _EMIT IS EMIT  [']    _TYPE IS TYPE ;

: dis_output ( -- )  
     ['] dis_CR IS CR  ['] dis_EMIT IS EMIT  ['] dis_TYPE IS TYPE ;

: silent ( -- ) 
     ['] noop is CR    ['] drop is EMIT      ['] 2drop is TYPE ;

: temp_silent ( -- )  r> 
     [ ' CR   >body ] Literal save
     [ ' EMIT >body ] Literal save
     [ ' TYPE >body ] Literal save
     silent  >r ;

: .addr   ( addr -- )    0 <#  [ data_width 3 + 4 / ] Literal 0 DO  #  LOOP  #> type ." : " ;

: .opcode ( opcode -- )  0 <#  [ #code 3 + 4 / ] Literal 0 DO  #  LOOP  #> type space ;

: tdump  ( caddr quan -- )  temp_hex
   cells bounds ?DO
      cr I .addr space
      I >memory $10 cells bounds DO  I @ .opcode  1 cells +LOOP
   $10 +LOOP
;
: .stack  ( opcode -- )  #stack and
   #none case? IF  ." none "  EXIT THEN
   #push case? IF  ." push "  EXIT THEN
   #pop  =     IF  ." pop "   EXIT THEN
                   ." both "
;
: .type   ( opcode -- )  #type and
   #bra case? IF  ." bra "  EXIT THEN
   #alu case? IF  ." alu "  EXIT THEN
   #mem     = IF  ." mem "  EXIT THEN
                  ." usr "
;
: .listname?  ( caddr link -- f )
   swap >r
   BEGIN  @ dup
   WHILE  dup cell- @ r@ =
          IF  cell- .wordname  r>  EXIT THEN
   REPEAT  rdrop
;
: .listname  ( caddr link -- )   .listname? drop ;

: a_call?  ( caddr n -- caddr n ff | caddr+1 tf )
   over opcode@ op_CALL - IF  false  EXIT THEN
   op_CALL .opcode  results
   over + 1+   dup Colons .listname  tu. ." call"
   1+ true
;
: a_branch? ( opcode -- addr | ff )
   Branches
   BEGIN  @ dup
   WHILE  2dup 2 cells - @ = IF  nip EXIT THEN
   REPEAT  nip
;
: a_condition?  ( caddr n -- caddr n ff | caddr+1 tf )
   over opcode@ a_branch? dup 0= ?EXIT
   >r  over opcode@ .opcode
   results  over + 1+
   dup Colons .listname   tu.
   r> 2 cells - .wordname
   1+ true
;
: literals? ( caddr -- caddr ff | caddr' tf )
   dup opcode@ lit_op? 0= IF  false  EXIT THEN
   dup nibbles@ 0 ?DO  .opcode  LOOP
   dup >branch drop   swap nibbles@ nibbles>
   a_call?      IF  true  EXIT THEN
   a_condition? IF  true  EXIT THEN
   over opcode@ nop? IF  op_NOP .opcode  swap 1+ swap  THEN
   results dup . tu.   true
;
: .inst_name  ( opcode link -- opcode ff | tf )
   BEGIN  @ dup
   WHILE  2dup 2 cells - @ =
          IF  results  2 cells - .wordname drop true  EXIT THEN
   REPEAT
;
: ld?  ( opcode -- f )    #groupmask and op_LOAD  = ;

: st?  ( opcode -- f )    #groupmask and op_STORE = ;

: small_number  ( u -- n )  #group and  dup 4 and IF -1 2* 2* or THEN ;

: .autoinc  ( n1 -- )
   small_number dup 0< IF  negate . ." - " EXIT THEN  . ." + "
;
: decode  ( opcode -- )
   Branches .inst_name ?EXIT
   BEGIN BEGIN
            Operators .inst_name ?EXIT
            dup ld? over st? or
         WHILE  results dup .autoinc #groupmask and
         REPEAT
         dup #groupmask and [ #alu #push or ] Literal =
   WHILE  ." 2dup " POP
   REPEAT
   dup .type dup .stack #group and .
;
: macro?  ( caddr -- caddr' tf | caddr ff )
   Expand @ IF  False  EXIT THEN
   dup macro@ dup 0= ?EXIT  >r           \ macro# on rstack
   BEGIN  dup macro@ r@ =
   WHILE  dup opcode@ .opcode  1+
   REPEAT results  true
   Macros BEGIN  @ ?dup
   WHILE  dup cell- @ r@ =
          IF  2 cells - .wordname rdrop EXIT THEN
   REPEAT ." macro"  r> .
;
: .instruction  ( caddr -- caddr' )  temp_hex
   cr dup Colons .listname? IF  results ." ---------------" cr  THEN
   dup .addr
   macro?    ?EXIT
   literals? ?EXIT
   dup 1+ swap opcode@   dup .opcode  decode
;
: break_key?  ( -- f )   key dup #cr = swap #esc = or ;

: disasm  ( caddr -- )  \ displays one instruction per key pressed. <cr> or <esc> to finish
   dis_output
   BEGIN  .instruction  break_key? UNTIL
   drop space std_output
;
: show    ( <name> -- )
   Context @ >r
   postpone T defined 0= ?missing
   r> Context !
   >body @ disasm
;

Root definitions

' show Alias show

ClassRoot definitions

: show  ( <name> -- )  classorder show ;

Forth definitions