(    "DECOM1"  A RECURSIVE FORTH DECOMPILER )
(               for the HP 71B )
(        by George G. Pinney (462)   
 
   HEX      ( LOAD IN HEX)
   VARIABLE NEST   ( = Depth of nesting)
   VARIABLE RFLAG   ( 0 for Prim.,Defining or RTA)
   VARIABLE 1STEP  ( Load non 0 to single step)
   ' FORTH 2- -1 TRAVERSE 5- NEST !  ( NEST=FORTH word)
   0 1STEP !
   : BUFFER   6E MAKEBF NOT ABORT" no room" RFLAG ! DROP ;
   : MOVE   SP@ RFLAG @ FINDBF 5+ 35 CMOVE> SP! ;
   : WHICH?   NEST @ 2FC8D = IF SP! EXIT THEN MOVE ;
   BUFFER   ( make 110 nib buffer,ID# in RFLAG)
   E71E8 E601C E0168 E3F81    ( Block of addr.'s)
   E3FF1 E1C67 E5D99 E5D86    ( for FORTH/ASSEM ROM)
   E580E E0640 E0EFA E22ED    ( placed on the)
   E1C54 13BF8 E70B7 E7080    ( stack.)
   E7043 E702F E706D E701A E71E8
   MOVE  ( move addr.'s on stack to buffer)
   E797E E68BE E01C3 E48B5    ( Block of addr.'s)
   E4925 E2096 E663B E6628    ( for 41TRANS ROM)
   E612D E069B E0FAF E2AB3    ( placed on the)
   E2083 8D1F8 E784D E7816    ( stack.)
   E77D9 E77C5 E7803 E77B0 E797E
   WHICH?   ( if FORTH/ASSEM---1st block else 2nd block)
   FORGET BUFFER     ( forgets BUFFER,MOVE,& WHICH?)
   -1 CONSTANT -1
  : 1STEP?   1STEP @ 0= NOT ;
  : ?NEST   NEST @ DUP 0>  ( Checks depth of)
       IF 0 DO             ( nesting. Display)
         2A EMIT SPACE LOOP    ( * for each layer in.)
          ELSE DROP THEN ;
  : DEC. BASE @ SWAP DECIMAL . ." D." BASE ! ;
  : SCROLL   " SCROLL 1" BASICX ;
  : HD.   DUP H. ." H. " DEC. ;  ( D. is signed)
  : DUP@   DUP @ ;               ( H. is not)
  : 2SPACE   2 SPACES ;
  : ADR.   DUP U. 2SPACE ;  ( Addr---Addr)
  : PRIM?   DUP DUP >BODY SWAP @ = ;    ( CFA---CFA,f)
  : IMMED?   C@ 40 AND 0> ;   ( NFA---f)
  : SCOLON?   DUP@   ( PFW---PFW,f)
      [ RFLAG @ FINDBF 1STEP DUP 5 SWAP +! @ + @ ] LITERAL = ;
  : COLON?   DUP@   ( CFA---CFA,f)
      [ RFLAG @ FINDBF 1STEP DUP 5 SWAP +! @ + @ ] LITERAL = ;
  : >NAME   2- -1 TRAVERSE ;    ( CFA---NFA)
  : NAME>   1 TRAVERSE 2+ ;    ( NFA---CFA)
  : MYSELF   LATEST NAME> , ; IMMEDIATE
  : -RFLAG   0 RFLAG ! ;   ( Disallow Recursion)
  : +RFLAG   -1 RFLAG ! ;  ( Allow Recursion)
  : .NAME   DUP COUNT   ( NFA---Print <NAME>)
      1F AND 1- TYPE
       1 TRAVERSE C@ 7F AND EMIT ;
  : "STR+   22 EMIT SPACE TYPE 22 EMIT
         COUNT 2* + 5- ;  ( ---Type str.,next PFA)
  : ?ROM   F0000 AND E0000 = IF ."  (r)" THEN ;
  : HEADER.   DUP >NAME ADR. DUP .NAME 2SPACE ?ROM ;
  : VAR?   DUP DUP 5- >NAME  ( PFA---PFA,F)
         SWAP 5+ DUP@   ( Is PF 8 bytes ?)
          ROT = SWAP HERE = OR ;   ( True = FVAR)
  : ?KEY   BEGIN KEY
    CASE
   51 ( Q) OF ABORT"  done"   ( Any time)
    ENDOF
   49 ( I) OF RFLAG @   ( If prim., RTA,or)
     IF 49 -1 ELSE 0 THEN  ( defining word---continue loop)
    ENDOF
   4F ( O) OF NEST @ 0>   ( if not in a layer)
     IF 4F -1 ELSE 0 THEN   ( continue loop)
    ENDOF 
      DROP SCOLON?  ( if ; only key is Q or maybe O)
     IF 0 ELSE 50 -1 THEN DUP  ( key 50 is arbitrary)
    ENDCASE UNTIL ;   ( so back to COLON & next word)
  : ?DEFINE 
     CASE    ( Is it a Defining Word ?)
   [ RFLAG @ FINDBF 1STEP DUP 5 SWAP +! @ + @ ] LITERAL OF EXECUTE VAR?
     IF @ ."   VAR = " HD.
      ELSE ."   FVAR = D. "
       RCL F. FDROP
      THEN -RFLAG
     ENDOF
   [ RFLAG @ FINDBF 1STEP DUP 5 SWAP +! @ + @ ] LITERAL OF EXECUTE
      ."   CON = " HD. -RFLAG
     ENDOF
   [ RFLAG @ FINDBF 1STEP DUP 5 SWAP +! @ + @ ] LITERAL OF EXECUTE
      ."   FCON = D. "
              F. FDROP -RFLAG
     ENDOF
[ RFLAG @ FINDBF 1STEP DUP 5 SWAP +! @ + @ ] LITERAL OF ."   STR Max. Chars. = "
      5+ C@ DEC. -RFLAG
     ENDOF
   [ RFLAG @ FINDBF 1STEP DUP 5 SWAP +! @ + @ ] LITERAL OF ."   STR-ARRAY  "
      5+ DUP 2+ C@ DEC.
      ."  Elements of "
       C@ DEC. ."  Chars. Max." -RFLAG
     ENDOF DUP@
   [ RFLAG @ FINDBF 1STEP DUP 5 SWAP +! @ + @ ] LITERAL OF ."   Son of "  ( Defined by ?)
     BEGIN 5- COLON? UNTIL
      >NAME ." <" .NAME ." >" DROP -RFLAG
     ENDOF 2DROP ENDCASE ;
  : (PFW)   DUP    ( PFA+5,PFW---)
       >NAME     ( PFW is a CFA,get NFA)
         DUP IMMED?
     IF ."  [COMPILE] " THEN
      DUP .NAME 2SPACE ?ROM PRIM?  ( Print NAME)
       IF ." (p)" -RFLAG THEN DROP
        5- DUP@ DUP@ ?DEFINE DUP ;
  : ?RTA   DUP 5+ SWAP @  ( PFA---PFA+5,PFW)
     -RFLAG CASE      ( Run time address ?)
   [ RFLAG @ FINDBF 1STEP DUP 5 SWAP +! @ + @ ] LITERAL
    ( Literal) OF ." LIT. "
     DUP@ DUP DUP 80000 AND 0=
      IF ." +" THEN . 2SPACE U.
     ENDOF [ RFLAG @ FINDBF 1STEP DUP 5 SWAP +! @ + @ ] LITERAL
    ( FLiteral) OF DUP ." FLIT. D. "
       RCL F. FDROP 5+ 5+ 1+
     ENDOF [ RFLAG @ FINDBF 1STEP DUP 5 SWAP +! @ + @ ] LITERAL
    ( .") OF DUP COUNT
      ." ." "STR+
     ENDOF [ RFLAG @ FINDBF 1STEP DUP 5 SWAP +! @ + @ ] LITERAL
    ( ") OF 2+ DUP COUNT
      "STR+
    ENDOF [ RFLAG @ FINDBF 1STEP DUP 5 SWAP +! @ + @ ] LITERAL
   ( ABORT") OF DUP COUNT
     ." ABORT" "STR+
    ENDOF [ RFLAG @ FINDBF 1STEP DUP 5 SWAP +! @ + @ ] LITERAL
   ( IF or UNTIL or WHILE) OF DUP DUP@ DUP 0<
     IF
      ." UNTIL   If false Jump to BEGIN @ "
   ELSE
      ." IF/WHILE   If false Jump to "
     THEN + U.
    ENDOF [ RFLAG @ FINDBF 1STEP DUP 5 SWAP +! @ + @ ] LITERAL
   ( ELSE/REPEAT) OF DUP DUP@ DUP 0<
     IF
      ." REPEAT   Jump to BEGIN @ "
   ELSE
      ." ELSE   Jump to THEN @ "
     THEN + U.
    ENDOF [ RFLAG @ FINDBF 1STEP DUP 5 SWAP +! @ + @ ] LITERAL
   ( DO) OF ." DO   (in loop R@=I)" 5-
    ENDOF [ RFLAG @ FINDBF 1STEP DUP 5 SWAP +! @ + @ ] LITERAL
   ( LOOP) OF DUP
      ." LOOP   Jump to DO @ " DUP@ + 5- U.
    ENDOF [ RFLAG @ FINDBF 1STEP DUP 5 SWAP +! @ + @ ] LITERAL
   ( +LOOP) OF DUP
      ." +LOOP   Jump to DO @ " DUP@ + 5- U.
    ENDOF [ RFLAG @ FINDBF 1STEP DUP 5 SWAP +! @ + @ ] LITERAL
   ( J) OF ." J" 5-
    ENDOF [ RFLAG @ FINDBF 1STEP DUP 5 SWAP +! @ + @ ] LITERAL
   ( DOES>) OF ." DOES>" 2+
    ENDOF [ RFLAG @ FINDBF 1STEP DUP 5 SWAP +! @ + @ ] LITERAL
   ( ;) OF ." ;" 5- 1STEP? NOT
     IF SP! QUIT THEN
    ENDOF
       +RFLAG (PFW) ENDCASE CR ;
  : COLON   ?NEST  ( CFA---)
     ADR. ." :"  ( ---CFA,Print CFA)
      DUP >NAME IMMED?    ( ---CFA,f)
       IF ."  (IMMEDIATE)"
        THEN CR   ( CFA---)
      BEGIN
    >BODY ?NEST ADR.   ( ---PFA,PRINT PFA)
      ?RTA 1STEP?
       IF SCROLL ?KEY
     CASE
    49 ( I) OF 1 NEST +! DUP@ MYSELF  ( in 1 layer)
     ENDOF
    4F ( O) OF -1 NEST +! DROP R> DROP  ( out 1 layer)
     ENDOF ENDCASE THEN
      +RFLAG 0 UNTIL ;
  : DECOM   
     20 WORD FIND DUP 0=   ( ---CFA,f,f)
    ABORT" Not in Vocabulary"
      SWAP PRIM?  ( ---f,CFA,f)
    IF
     HEADER.
       SWAP 0>
        ABORT" (Prim.,IMMEDIATE)"
         ABORT" (Prim.)"
      THEN   ( drop immediate flag)
      SWAP DROP COLON?    ( ---CFA,f)
    IF HEADER. CR     ( true=never returns)
      0 NEST ! +RFLAG COLON    ( from COLON)
     THEN DUP HEADER.  ( false=defining word)
        @ ?DEFINE SCROLL QUIT ;
   RFLAG @ KILLBF