GEMini Atari/GEMini_Atari_CD-ROM_Walnut_Creek_December_1993.iso/files/language/sbprolog/_decompi.p

Text File | 1993-10-23 | 20.7 KB | 620 lines

/************************************************************************
*                                    *
* The SB-Prolog System                            *
* Copyright SUNY at Stony Brook, 1986; University of Arizona,1987    *
*                                    *
************************************************************************/

/*-----------------------------------------------------------------
SB-Prolog is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY.  No author or distributor
accepts responsibility to anyone for the consequences of using it
or for whether it serves any particular purpose or works at all,
unless he says so in writing.  Refer to the SB-Prolog General Public
License for full details.

Everyone is granted permission to copy, modify and redistribute
SB-Prolog, but only under the conditions described in the
SB-Prolog General Public License.   A copy of this license is
supposed to have been given to you along with SB-Prolog so you
can know your rights and responsibilities.  It should be in a
file named COPYING.  Among other things, the copyright notice
and this notice must be preserved on all copies.
------------------------------------------------------------------ */

/* This file contains predicates that traverse a buffer containing
   asserted code, and reconstruct the clause that was asserted.  This
   code is tied fairly tightly to the code generated by "assert", so
   changes to assert may require corresponding updates to this code.
   This also means that compiled code (i.e. that generated by "compile")
   cannot be decompiled.                    */

$decompile_export([$clause/2,$clause/3,$listing/1,$instance/2,$listing/0]).

$decompile_use($bio, [$writename/1,_,_,$nl/0,_,$tell/1,_,$telling/1,
              $told/0,_,_,_,_,_,_]).
$decompile_use($buff, [_,_,_,$buff_code/4,$symtype/2,_,_,_,_,_,_]).
$decompile_use($bmeta,[_,_,_,_,_,_,_,_,$arity/2,_,_,$mkstr/3,$is_buffer/1]).
$decompile_use($meta,[$functor/3,_,_]).
$decompile_use($assert,[_,_,_,_,_,_,_,_,_,_,$assert_get_prref/2,_,_]).
$decompile_use($blist,[$append/3,_,$memberchk/2,_]).
$decompile_use($deb,[$debug/0,$nodebug/0,_,_,_,_,_,_,_,_,_,$deb_set/3,
         $deb_unset/1]).
$decompile_use($currsym,[_,_,$predicate_property/2,_,_,_,_,_]).


$clause(Hd,Body) :- $clause(Hd,Body,_,1).

$clause(Hd,Body,Ref) :- $clause(Hd,Body,Ref,1).

$clause(Hd,Body,Ref,Xform) :-
     nonvar(Hd),
     !,
     $decompile(Hd, Body, Ref, Xform).
$clause(Hd,Body,Ref,Xform) :-
     $is_buffer(Ref),    /* better be a DB ref! */
     $dec_getpsc(Ref,16,_,Psc),
     $mkstr(Psc,Hd0,Arity),
     !,
     $decompile_clause(Ref,Arity,Hd0,Body0),
     (Body0 ?= true ->
          (Hd = Hd0, Body = Body0) ;
      (arg(Arity,Hd0,CutArg),
       $dec_xform(Body0,CutArg,Body,Xform),
       RArity is Arity - 1,
       $functor(Hd0,Pred,_), $functor(Hd,Pred,RArity),
       $dec_copyargs(RArity,Hd0,Hd)
      )
     ).
$clause(Hd,B,R,_) :-
     $telling(X), $tell(stderr),
     $writename('*** Error: illegal argument(s) to clause/[2,3]: <'),
     $write(Hd), $write(', '), $write(B), $write(', '), $write(R), $write('> ***'), $nl,
     $told, $tell(X),
     fail.

$listing :-
     $predicate_property(X,interpreted),
     $functor(X,P,N),
     $listing(P/N),
     fail.
$listing.

$listing(Pred) :- $listing(Pred,1).

$listing([],_) :- !.
$listing([H|L],Xform) :-
     !,
     ($listing(H,Xform) -> true ; true),   /* do the rest anyway */
     $listing(L,Xform).
$listing(Pred,Xform) :-
     nonvar(Pred) ->
          (Pred = P/N ->
           ($functor(Hd,P,N),
            ($decompile(Hd,Body,_,Xform),
             $portray_clause((Hd :- Body)),
             fail    /* backtrack to get all clauses */
            ) ;
            true
           ) ;
           ($errmsg('*** Error: argument to listing/1 must be of the form <pred>/<arity>'), $nl
           )
      ) ;
        ($errmsg('*** Error: argument to listing/1 must be instantiated ***'), fail).


$instance(Ref, Instance) :-
     $is_buffer(Ref) ->
          $instance_1(Ref, Instance) ;
      ($telling(X), $tell(stderr),
       $write('*** Error: argument 1 of instance/2 must be a DB reference ***'), $nl,
       $told, $tell(X),
       fail
      ).

$instance_1(Ref, Instance) :-
     $clause(H, B, Ref),
     (H = '_$record_db'(_, Instance) ->
          true ;
      Instance = (H :- B)
     ).

$dec_getbuffwd(Buff,Li,Lo,Word) :-
    Lo is Li+2, $buff_code(Buff,Li,6 /* gb */,Word).

$dec_getbuffnum(Buff,Li,Lo,Num) :-
    Lo is Li+4, $buff_code(Buff,Li,5 /* gn */,Num).

$dec_getbuffloat(Buff,Li,Lo,Num) :-
    Lo is Li+4, $buff_code(Buff,Li,29 /* gf */,Num).

$dec_getpsc(Buff,Li,Lo,Psc) :-
    Lo is Li+4, $buff_code(Buff,Li,28 /* gppsc */, Psc).

$decompile(Head, Body, Clref, Xform) :-
     $functor(Head,P,N),
     $symtype(Head, Type),
     (Type =\= 1 ->
          ($dec_errmsg(Type,P,N), fail) ;
      ($dec_GetPrref(Head,Prref),
           $buff_code(Prref,8,8 /* gpb */, FirstClref),
       $clause_addr(FirstClref, Clref,P,N),
       NArity is N + 1,    /* extra argument introduced during assert
                      to handle cuts */
           $functor(NHd,P,NArity),
       $dec_copyargs(N,Head,NHd),
       arg(NArity,NHd,CutArg),
       $decompile_clause(Clref, NArity, NHd, Body0),
       $dec_xform(Body0,CutArg,Body,Xform)
      )
     ).

$dec_GetPrref(Head,Prref) :-
     $assert_get_prref(Head, Prref0),
     $dec_getbuffwd(Prref0,4,_,Op),
     (Op =:= 91 /* jumptbreg */ ->  /* clause present, no interception */
          Prref = Prref0 ;
      (Op =:= 92 /* unexec */ ->  /* call intercept: trace/ET &c. */
           ($functor(Head,P,N), Pred = P/N,
            $dec_undo_inters(Pred,Inters),
        $dec_GetPrref(Head,Prref),
        $dec_do_inters(Inters,P,N)
           )
     )
     ).

$dec_undo_inters(Pred,Inters) :-   /* undo effects of call interception */
     (($symtype('_$traced_preds'(_),TType),
       TType > 0,
       '_$traced_preds'(Pred)
      ) ->
          (Inters = [trace|I0], $deb_unset(Pred)) ;
      Inters = I0
     ),
     (($symtype('_$spy_points'(_),SType),
       SType > 0,
       '_$spy_points'(Pred)
      ) ->
          (I0 = [spy|I1], $deb_unset(Pred)) ;
      I0 = I1
     ),
     (($symtype($deb_ugging(_),DType),
       DType > 0
      ) ->
           (I1 = [debugging(X)], $deb_ugging(X)) ;
       I1 = []
     ).

$dec_do_inters([],P,A).
$dec_do_inters([I|IRest],P,A) :-
     $dec_do_inters1(I,P,A), $dec_do_inters(IRest,P,A).

$dec_do_inters1(trace,P,A) :- $deb_set(P,A,$deb_trace(_)).
$dec_do_inters1(spy,  P,A) :- $deb_set(P,A,$deb_spy(_)).
$dec_do_inters1(debugging(X),_,_) :- X =:= 1 -> $debug ; $nodebug.

/* $clause_addr/4 takes the reference of the first clause for a predicate,
   and returns the reference of a clause for the predicate, backtracking
   successively through all of them.                    */

$clause_addr(CurrClref,Clref,P,N) :-
     $buff_code(CurrClref,4,6 /* gb */, Sop),
     ((Sop =:= 44 ; Sop =:= 85) ->     /* trustmeelsefail or noop */
          $clause_addr1(CurrClref,Clref,P,N) ;
      ((Sop =:= 42 ; Sop =:= 43) -> /* trymeelse or retrymeelse */
           ($buff_code(CurrClref,8,8 /* gpb */, NextClref),
            ($clause_addr1(CurrClref,Clref,P,N) ;
         $clause_addr(NextClref, Clref,P,N)  /* get next clause */
        )
           )
     )
     ).

$clause_addr1(CurrCl,Cl,P,N) :-
     $buff_code(CurrCl,20,6 /* gb */,55) ->    /* check if SOB-buffer */
         ($buff_code(CurrCl,36,8 /* gpb */,Clref),
      $clause_addr(Clref,Cl,P,N)
     ) ;
     ($buff_code(CurrCl,12,6 /* gb */,77 /* jump */) ->
          ($telling(X), $tell(stderr),
           $writename('*** Warning: '),
               $writename(P), $writename('/'), $writename(N),
               $writename(' contains compiled code that is not being decompiled ***'), $nl,
               $told, $tell(X),
           fail
          ) ;
          Cl = CurrCl
         ).

$decompile_clause(Clref, N, Head, Body) :-
     $buff_code(Clref,12,6 /* gb */, Op),
     $opcode(fail, FailOp),
     Op =\= FailOp, /* make sure the clause hasn't been erased */
     $dec_mk_rmap(4,4,Rmap0),
     $decompile_head(Clref,1,N,Head,20,Lm,Rmap0,Rmap1),
     $decompile_body(Clref,Body,Lm,Rmap1).

$decompile_head(Buff,Arg,Arity,Term,Li,Lo,Rmap0,Rmap1) :-
     Arg > Arity ->
          (Li = Lo, Rmap0 = Rmap1) ;
           ($dec_getbuffwd(Buff,Li,Lm0,Op),
       $dec_argreg(Op,Buff,Lm0,Reg),
       (Reg =:= Arg ->
            $dec_hdarg(Op,Buff,Term,Lm0,Lm1,Rmap0,Rmap2) ;
        (Lm1 = Li, Rmap2 = Rmap0,
         $dec_map_lookup(Arg,Rmap0,X),
         arg(Arg,Term,X)
        )
       ),
       NextArg is Arg+1,
       $decompile_head(Buff,NextArg,Arity,Term,Lm1,Lo,Rmap2,Rmap1)
      ).

$dec_hdarg(3,Buff,Term,Li,Lo,Rmap,Rmap) :-    /* gettval(R1,R2) */
    Li1 is Li+2,    /* skip pad word */
    $dec_getbuffwd(Buff,Li1,Lm1,Arg1),
    $dec_getbuffwd(Buff,Lm1,Lo,Arg2),
    arg(Arg1,Term,T), arg(Arg2,Term,T),
    $dec_map_lookup(Arg1,Rmap,T),
    $dec_map_lookup(Arg2,Rmap,T).
$dec_hdarg(4,Buff,Term,Li,Lo,Rmap,Rmap) :-    /* getcon(Con, N) */
    $dec_getbuffwd(Buff,Li,Lm,Arg),
    arg(Arg,Term,Const),
    $dec_getpsc(Buff,Lm,Lo,Const),
    $dec_map_lookup(Arg,Rmap,Const).
$dec_hdarg(5,Buff,Term,Li,Lo,Rmap,Rmap) :-    /* getnil(N) */
    $dec_getbuffwd(Buff,Li,Lo,Arg),
    arg(Arg,Term,[]),
    $dec_map_lookup(Arg,Rmap,[]).
$dec_hdarg(6,Buff,Term,Li,Lo,R0,R1) :-        /* getstr(Str,N) */
    $dec_getbuffwd(Buff,Li,Lm1,Arg),
    $dec_getpsc(Buff,Lm1,Lm2,Func),
    $mkstr(Func,Str,Arity),
    arg(Arg,Term,Str),
    $dec_subs(1,Arity,Buff,Str,Lm2,Lo,R0,R1),
    $dec_map_lookup(Arg,R1,Str).
$dec_hdarg(7,Buff,Term,Li,Lo,R0,R1) :-        /* getlist(N) */
    $dec_getbuffwd(Buff,Li,Lm1,Arg),
    List = [_|_], arg(Arg,Term,List),
    $dec_subs(1,2,Buff,List,Lm1,Lo,R0,R1),
    $dec_map_lookup(Arg,R1,List).
$dec_hdarg(14,Buff,Term,Li,Lo,Rmap,Rmap) :-    /* getnumcon(Num, N) */
    $dec_getbuffwd(Buff,Li,Lm,Arg),
    arg(Arg,Term,N),
    $dec_getbuffnum(Buff,Lm,Lo,N),
    $dec_map_lookup(Arg,Rmap,N).
$dec_hdarg(32,Buff,Term,Li,Lo,Rmap,Rmap) :-    /* getfloatcon(Num, N) */
    $dec_getbuffwd(Buff,Li,Lm,Arg),
    arg(Arg,Term,N),
    $dec_getbuffloat(Buff,Lm,Lo,N),
    $dec_map_lookup(Arg,Rmap,N).
$dec_hdarg(39,Buff,Term,Li,Lo,Rmap,Rmap) :-    /* getlist_tvar_tvar */
    $dec_getbuffwd(Buff,Li,Lm0,Arg),
    $dec_getbuffwd(Buff,Lm0,Lm1,R1),
    $dec_getbuffwd(Buff,Lm1,Lo,R2),
    $dec_map_lookup(R1,Rmap,A1),
    $dec_map_lookup(R2,Rmap,A2),
    Sub = [A1|A2], arg(Arg,Term,Sub),
    $dec_map_lookup(Arg,Rmap,Sub).
$dec_hdarg(40,Buff,Term,Li,Lo,R0,R1) :-        /* getcomma(N) */
    $dec_getbuffwd(Buff,Li,Lm1,Arg),
    Sub = ','(_,_), arg(Arg,Term,Sub),
    $dec_subs(1,2,Buff,Sub,Lm1,Lo,R0,R1),
    $dec_map_lookup(Arg,R1,Sub).
$dec_hdarg(41,Buff,Term,Li,Lo,Rmap,Rmap) :-    /* getcomma_tvar_tvar */
    $dec_getbuffwd(Buff,Li,Lm0,Arg),
    $dec_getbuffwd(Buff,Lm0,Lm1,R1),
    $dec_getbuffwd(Buff,Lm1,Lo,R2),
    $dec_map_lookup(R1,Rmap,A1),
    $dec_map_lookup(R2,Rmap,A2),
    Sub = ','(A1,A2), arg(Arg,Term,Sub),
    $dec_map_lookup(Arg,Rmap,Sub).

/* $dec_argreg/3 returns the "main" register number for an instruction in
   a buffer.  Argument 1 is the opcode of the "current" instruction. */

$dec_argreg(3,Buff,Disp,N) :-            /* gettval(R,N) */
     Lr is Disp + 4,        /* skip pad byte, op1 */
     $buff_code(Buff,Lr,6 /* gb */, N).
$dec_argreg(Op,Buff,Disp,N) :-
     Op >= 4, Op =< 7, /* getcon(C,N)|getnil(N)|getstr(Str,N)|getlist(N) */
     $buff_code(Buff,Disp,6 /* gb */, N).
$dec_argreg(14,Buff,Disp,N) :-            /* getnumcon(Num,N) */
     $buff_code(Buff,Disp,6 /* gb */, N).
$dec_argreg(32,Buff,Disp,N) :-            /* getfloatcon(Num,N) */
     $buff_code(Buff,Disp,6 /* gb */, N).
$dec_argreg(Op,Buff,Disp,N) :-
     Op >= 39, /* getlist_tvar_tvar(N,_,_) | getcomma(N) | */
     Op =< 41, /* getcomma_tvar_tvar(N,_,_) */
     $buff_code(Buff,Disp,6 /* gb */, N).

/*  if we hit a "put" instruction we know we're past the head, so return an
    "impossible" register number.                    */
$dec_argreg(15,Buff,Disp,-1).        /* putnumcon(Num,N) */
$dec_argreg(18,Buff,Disp,-1).        /* puttvar(T,R) */
$dec_argreg(20,Buff,Disp,-1).        /* putcon(C,R) */
$dec_argreg(21,Buff,Disp,-1).        /* putnil(R) */
$dec_argreg(22,Buff,Disp,-1).        /* putstr(S,R) */
$dec_argreg(23,Buff,Disp,-1).        /* putlist(R) */
$dec_argreg(33,Buff,Disp,-1).        /* putfloatcon(Num,N) */
$dec_argreg(58,Buff,Disp,-1).        /* movreg(T,R) */
$dec_argreg(74,Buff,Disp,-1).        /* proceed */
$dec_argreg(75,Buff,Disp,-1).        /* execute(P) */

$dec_subs(N,Arity,Buff,Term,Li,Lo,Rin,Rout) :-
    N > Arity ->
        (Li = Lo, Rin = Rout) ;
    ($dec_getbuffwd(Buff,Li,Lm1,Op),
     $dec_sub(Op,Buff,Sub,Lm1,Lm2,Rin,Rmid),
     arg(N,Term,Sub),
     N1 is N+1,
     $dec_subs(N1,Arity,Buff,Term,Lm2,Lo,Rmid,Rout)
    ).

$dec_sub(10,Buff,X,Li,Lo,Rmap,Rmap) :-        /* unitvar(R) */
    $dec_getbuffwd(Buff,Li,Lo,R),
    $dec_map_lookup(R,Rmap,X).
$dec_sub(11,Buff,X,Li,Lo,Rmap,Rmap) :-        /* unitval(R) */
    $dec_getbuffwd(Buff,Li,Lo,R),
    $dec_map_lookup(R,Rmap,X).
$dec_sub(12,Buff,Con,Li,Lo,Rmap,Rmap) :-    /* unicon(Con) */
    Lm is Li+2,    /* skip pad bytes */
    $dec_getpsc(Buff,Lm,Lo,Con).
$dec_sub(13,Buff,[],Li,Lo,Rmap,Rmap) :-        /* uninil */
    Lo is Li + 2.
$dec_sub(26,Buff,X,Li,Lo,Rin,Rout) :-        /* bldtvar(R) */
    $dec_getbuffwd(Buff,Li,Lo,R),
    $dec_map_update(R,Rin,X,Rout).
$dec_sub(27,Buff,X,Li,Lo,Rmap,Rmap) :-        /* bldtval(R) */
    $dec_getbuffwd(Buff,Li,Lo,R),
    $dec_map_lookup(R,Rmap,X).
$dec_sub(28,Buff,Con,Li,Lo,Rmap,Rmap) :-    /* bldcon(Con) */
    Lm is Li+2,    /* skip pad byte */
    $dec_getpsc(Buff,Lm,Lo,Con).
$dec_sub(29,Buff,[],Li,Lo,Rmap,Rmap) :-        /* bldnil */
    Lo is Li + 2.
$dec_sub(30,Buff,Num,Li,Lo,Rmap,Rmap) :-    /* uninumcon(Num) */
    Lm is Li+2,    /* skip pad bytes */
    $dec_getbuffnum(Buff,Lm,Lo,Num).
$dec_sub(31,Buff,Num,Li,Lo,Rmap,Rmap) :-    /* bldnumcon(Num) */
    Lm is Li+2,    /* skip pad bytes */
    $dec_getbuffnum(Buff,Lm,Lo,Num).
$dec_sub(34,Buff,Num,Li,Lo,Rmap,Rmap) :-    /* unifloatcon(Num) */
    Lm is Li+2,    /* skip pad bytes */
    $dec_getbuffloat(Buff,Lm,Lo,Num).
$dec_sub(35,Buff,Num,Li,Lo,Rmap,Rmap) :-    /* bldfloatcon(Num) */
    Lm is Li+2,    /* skip pad bytes */
    $dec_getbuffloat(Buff,Lm,Lo,Num).


$decompile_body(Buff,Body,Loc,Rmap) :-
     $dec_getbuffwd(Buff,Loc,Lm0,Op),
     (Op =:= 74 ->                /* proceed */
          Body = true ;
      (Op =:= 75 ->            /* execute(P) */
           (Lm1 is Lm0 + 2,    /* skip pad bytes */
            $dec_getpsc(Buff,Lm1,_,Psc),
        $mkstr(Psc,Body,Arity),
        $dec_procputs(Arity,Rmap,Body)
           ) ;
           ($dec_bodyinst(Op,Buff,Lm0,Lm1,Rmap,Rmap0),
            $decompile_body(Buff,Body,Lm1,Rmap0)
           )
      )
     ).

$dec_bodyinst(3,Buff,Li,Lo,Rmap,Rmap) :-    /* gettval(R1,R2) */
     Li1 is Li+2,    /* skip pad bytes */
     $dec_getbuffwd(Buff,Li1,Lm1,Arg1),
     $dec_getbuffwd(Buff,Lm1,Lo,Arg2),
     $dec_map_lookup(Arg1,Rmap,T),
     $dec_map_lookup(Arg2,Rmap,T).
$dec_bodyinst(4,Buff,Li,Lo,Rmap,Rmap) :-    /* getcon(Con, N) */
     $dec_getbuffwd(Buff,Li,Lm,R),
     $dec_getpsc(Buff,Lm,Lo,Const),
     $dec_map_lookup(R,Rmap,Const).
$dec_bodyinst(5,Buff,Li,Lo,Rmap,Rmap) :-    /* getnil(N) */
     $dec_getbuffwd(Buff,Li,Lo,R),
     $dec_map_lookup(R,Rmap,[]).
$dec_bodyinst(6,Buff,Li,Lo,Rin,Rout) :-        /* getstr(Str,N) */
     $dec_getbuffwd(Buff,Li,Lm1,R),
     $dec_getpsc(Buff,Lm1,Lm2,Func),
     $mkstr(Func,Str,Arity),
     $dec_map_lookup(R,Rin,Str),
     $dec_subs(1,Arity,Buff,Str,Lm2,Lo,Rin,Rout).
$dec_bodyinst(7,Buff,Li,Lo,Rin,Rout) :-        /* getlist(N) */
     $dec_getbuffwd(Buff,Li,Lm1,R),
     List = [_|_],
     $dec_map_lookup(R,Rin,List),
     $dec_subs(1,2,Buff,List,Lm1,Lo,Rin,Rout).
$dec_bodyinst(14,Buff,Li,Lo,Rmap,Rmap) :-    /* getnumcon(Num, N) */
     $dec_getbuffwd(Buff,Li,Lm,R),
     $dec_getbuffnum(Buff,Lm,Lo,N),
     $dec_map_lookup(R,Rmap,N).
$dec_bodyinst(15,Buff,Li,Lo,Rin,Rout) :-
     $dec_getbuffwd(Buff,Li,Lm,R),        /* putnumcon(Num,R) */
     $dec_getbuffnum(Buff,Lm,Lo,Num),
     $dec_map_update(R,Rin,Num,Rout).
$dec_bodyinst(18,Buff,Li,Lo,Rin,Rout) :-    /* puttvar(R1, R2) */
     Li1 is Li + 2,
     $dec_getbuffwd(Buff,Li1,Lm,R1),
     $dec_getbuffwd(Buff,Lm,Lo,R2),
     $dec_map_update(R1,Rin,X,Rmid),
     $dec_map_update(R2,Rmid,X,Rout).
$dec_bodyinst(20,Buff,Li,Lo,Rin,Rout) :-
     $dec_getbuffwd(Buff,Li,Lm,R),        /* putcon(Con,R) */
     $dec_getpsc(Buff,Lm,Lo,Con),
     $dec_map_update(R,Rin,Con,Rout).
$dec_bodyinst(21,Buff,Li,Lo,Rin,Rout) :-
     $dec_getbuffwd(Buff,Li,Lo,R),        /* putnil(R) */
     $dec_map_update(R,Rin,[],Rout).
$dec_bodyinst(22,Buff,Li,Lo,Rin,Rout) :-
     $dec_getbuffwd(Buff,Li,Lm0,R),        /* putstr(Str,R) */
     $dec_getpsc(Buff,Lm0,Lm1,Psc),
     $mkstr(Psc,Str,Arity),
     $dec_subs(1,Arity,Buff,Str,Lm1,Lo,Rin,Rmid),
     $dec_map_update(R,Rmid,Str,Rout).
$dec_bodyinst(23,Buff,Li,Lo,Rin,Rout) :-
     List = [_|_],                /* putlist(R) */
     $dec_getbuffwd(Buff,Li,Lm,R),
     $dec_map_update(R,Rin,List,Rmid),
     $dec_subs(1,2,Buff,List,Lm,Lo,Rmid,Rout).
$dec_bodyinst(32,Buff,Li,Lo,Rmap,Rmap) :-    /* getfloatcon(Num, N) */
     $dec_getbuffwd(Buff,Li,Lm,R),
     $dec_getbuffloat(Buff,Lm,Lo,N),
     $dec_map_lookup(R,Rmap,N).
$dec_bodyinst(33,Buff,Li,Lo,Rin,Rout) :-
     $dec_getbuffwd(Buff,Li,Lm,R),        /* putfloatcon(Num,R) */
     $dec_getbuffloat(Buff,Lm,Lo,Num),
     $dec_map_update(R,Rin,Num,Rout).
$dec_bodyinst(39,Buff,Li,Lo,Rmap,Rmap) :-    /* getlist_tvar_tvar */
     $dec_getbuffwd(Buff,Li,Lm0,R0),
     $dec_getbuffwd(Buff,Lm0,Lm1,R1),
     $dec_getbuffwd(Buff,Lm1,Lo,R2),
     $dec_map_lookup(R1,Rmap,A1),
     $dec_map_lookup(R2,Rmap,A2),
     $dec_map_lookup(R0,Rmap,[A1|A2]).
$dec_bodyinst(40,Buff,Li,Lo,Rin,Rout) :-    /* getcomma(N) */
     $dec_getbuffwd(Buff,Li,Lm1,R),
     Sub = ','(_,_), $dec_map_lookup(R,Rin,Sub),
     $dec_subs(1,2,Buff,Sub,Lm1,Lo,Rin,Rout).
$dec_bodyinst(41,Buff,Li,Lo,Rmap,Rmap) :-    /* getcomma_tvar_tvar */
     $dec_getbuffwd(Buff,Li,Lm0,R0),
     $dec_getbuffwd(Buff,Lm0,Lm1,R1),
     $dec_getbuffwd(Buff,Lm1,Lo,R2),
     $dec_map_lookup(R1,Rmap,A1),
     $dec_map_lookup(R2,Rmap,A2),
     $dec_map_lookup(R0,Rmap,','(A1,A2)).
$dec_bodyinst(58,Buff,Li,Lo,Rin,Rout) :-      /* movreg(R1,R2) */
     Lm0 is Li + 2,    /* skip pad bytes */
     $dec_getbuffwd(Buff,Lm0,Lm1,R1),
     $dec_getbuffwd(Buff,Lm1,Lo,R2),
     $dec_map_lookup(R1,Rin,Val),
     $dec_map_update(R2,Rin,Val,Rout).

$dec_procputs(Arg,Rmap,Body) :-
     Arg =:= 0 ->
          true ;
      ($dec_map_lookup(Arg,Rmap,Val),
       arg(Arg,Body,Val),
       Next is Arg - 1,
       $dec_procputs(Next,Rmap,Body)
      ).

$dec_xform(Body0,C,Body1,N) :-
     N > 0 -> $dec_xform_1(Body0,C,Body1) ; Body0 = Body1.

$dec_xform_1(','(A0,A1,A2,A3),C,(B0,B1,B2,B3)) :-
     !,
     $dec_xform_1(A0,C,B0),
     $dec_xform_1(A1,C,B1),
     $dec_xform_1(A2,C,B2),
     $dec_xform_1(A3,C,B3).
$dec_xform_1(','(A0,A1),C,','(B0,B1)) :-
     !,
     $dec_xform_1(A0,C,B0),
     $dec_xform_1(A1,C,B1).
$dec_xform_1(';'(A0,A1),C,';'(B0,B1)) :-
     !,
     $dec_xform_1(A0,C,B0),
     $dec_xform_1(A1,C,B1).
$dec_xform_1('->'(A0,A1),C,'->'(B0,B1)) :-
     !,
     $dec_xform_1(A0,C,B0),
     $dec_xform_1(A1,C,B1).
$dec_xform_1('_$cutto'(V),C,Lit) :-
     !,
     (C == V -> Lit = '!' ; Lit = '_$cutto'(V)).
$dec_xform_1(L,_,L).


$dec_errmsg(Type,P,N) :-
     $telling(X), $tell(stderr),
     $writename('*** Warning: '),
     $writename(P), $writename('/'), $writename(N),
     $dec_errmsg1(Type, ErrType),
     $writename(ErrType), $writename(', cannot decompile ***'), $nl,
     $told, $tell(X).

$dec_errmsg1(0, ' is undefined').
$dec_errmsg1(2, ' is compiled').

/*  The following predicates manipulate a "register map", which is
    basically an array of 256 elements represented as a complete quadtree
    of height 4.                            */

$dec_mk_rmap(Level,Arity,Map) :-
     $functor(Map,rm,Arity),
     (Level =:= 1 ->
         true ;
     (Lev1 is Level - 1,
      $dec_mk_rmaps(Arity,Arity,Lev1,Map)
     )
     ).

$dec_mk_rmaps(Argno,Arity,Level,Map) :-
     Argno =:= 0 ->
         true ;
     (arg(Argno,Map,SubMap),
      $dec_mk_rmap(Level,Arity,SubMap),
      NextArg is Argno - 1,
      $dec_mk_rmaps(NextArg,Arity,Level,Map)
     ).

$dec_map_lookup(I,Tree,Val) :-
     Index is I - 1,
     $dec_map_lookup(4,Index,Tree,Val).

$dec_map_lookup(Level,Index,Tree,Val) :-
    $get_currindex(Level,Index,CurrInd),
    (Level =:= 1 ->
         arg(CurrInd,Tree,Val) ;
     (arg(CurrInd,Tree,SubTree),
      NewLevel is Level - 1,
      $dec_map_lookup(NewLevel,Index,SubTree,Val)
     )
    ).

$dec_map_update(I,Tree,Val,NTree) :-
     Index is I-1,
     $dec_map_update(4,Index,Tree,Val,NTree).

$dec_map_update(Level,Index,Tree,Val,NTree) :-
    NTree = rm(_,_,_,_),
    $get_currindex(Level,Index,CurrInd),
    (Level =:= 1 ->
     $subst_arg(4,CurrInd,Tree,Val,NTree) ;
     (arg(CurrInd,Tree,SubTree),
      NewLevel is Level - 1,
      $dec_map_update(NewLevel,Index,SubTree,Val,NSubTree),
      $subst_arg(4,CurrInd,Tree,NSubTree,NTree)
     )
     ).

$subst_arg(N,I,Tree,Val,NTree) :-
     N =:= 0 ->                /* done! */
          true ;
      ((N =:= I ->            /* make the change */
           arg(N,NTree,Val) ;
           (arg(N,Tree,Arg), arg(N,NTree,Arg))
           ),
       N1 is N - 1,
       $subst_arg(N1,I,Tree,Val,NTree)
      ).

$get_currindex(Level,Index,N) :-
    Shift is (Level-1) << 1,  /* Shift = 2*(Level-1) */
    Mask is 2'11 << Shift,
    N is ((Index /\ Mask) >> Shift) + 1.

$dec_copyargs(N,T1,T2) :-
     N =:= 0 ->
          true ;
      (arg(N,T1,X), arg(N,T2,X),
       N1 is N - 1,
       $dec_copyargs(N1,T1,T2)
      ).

/* ----------------------------- $decompile.P ----------------------------- */