1/*******************************************************************
    2 *
    3 * A Common Lisp compiler/interpretor, written in Prolog
    4 *
    5 * (xxxxx.pl)
    6 *
    7 *
    8 * Douglas'' Notes:
    9 *
   10 * (c) Douglas Miles, 2017
   11 *
   12 * The program is a *HUGE* common-lisp compiler/interpreter. 
   13 *
   14 *******************************************************************/
   15:- module(dasm, []).   16
   17:- meta_predicate(maplist_not_tail(1,*)).   18
   19%f_disassemble(Function, Code):- string(Function),downcase_atom(Function,DC),!,f_disassemble(DC, Code).
   20f_disassemble(function(Symbol),Options, Code):- !, f_disassemble(Symbol,Options, Code).
   21f_disassemble([quote,Symbol], Options,Code):- !, f_disassemble(Symbol, Options,Code).
   22f_disassemble(StringL,Options,Code):- \+ string(StringL),is_stringp(StringL),to_prolog_string_if_needed(StringL,String),!,f_disassemble(String,Options,Code).
   23f_disassemble(Function,_Options, Prolog):- 
   24  writeln('#| DISASSEMBLY FOR':Function),
   25   make_holder(Holder),
   26   print_related_clauses(Holder,_Module,Function),
   27  nb_holder_value(Holder,ListOut),
   28  Prolog = '$OBJ'(claz_prolog,ListOut),
   29  nop(ListOut==[]-> xlisting(Function) ; true),
   30  writeln('|#').
   31
   32
   33clauses_related(M,Obj,H,B,PrintKeyRef):- nonvar(Obj), get_opv(Obj,symbol_function,Obj2),clauses_related(M,Obj2,H,B,PrintKeyRef).
   34%clauses_related(M,Obj,H,B,PrintKeyRef):- nonvar(Obj), get_opv(Obj2,symbol_function,Obj),clauses_related(M,Obj2,H,B,PrintKeyRef).
   35clauses_related(_,P,H,B,PrintKeyRef):-
   36   H= wl:lambda_def(_DefType,H1,H2,_Args,_Body),
   37   clause_interface(H,B,PrintKeyRef),
   38  (related_functor(P,H1);related_functor(P,H2)).
   39clauses_related(_,P,H,B,PrintKeyRef):-
   40   H= wl:arglist_info(H1,H2,_,_),
   41   clause_interface(H,B,PrintKeyRef),
   42  (related_functor(P,H1);related_functor(P,H2)).
   43clauses_related(_,P,H,B,PrintKeyRef):-
   44   H= wl:init_args(_,H1),
   45   clause_interface(H,B,PrintKeyRef),
   46  (related_functor(P,H1)).
   47clauses_related(Module,P,Module:H,B,PrintKeyRef):- 
   48  current_module(Module),
   49  current_predicate(_,Module:H),
   50  \+ predicate_property(Module:H,imported_from(_)),
   51  \+ predicate_property(Module:H,foreign),  
   52  clause_interface(Module:H,B,PrintKeyRef),
   53  related_functor(P,H).
   54
   55
   56related_functor(P,Q):- to_related_functor(P,PP),to_related_functor(Q,QQ),QQ=PP,!.
   57%to_related_functor(P,_):- \+ callable(P),!,fail.
   58to_related_functor(P,PP):- string(P),atom_string(A,P),!,to_related_functor(A,PP).
   59to_related_functor(P,PP):- \+ compound(P),!,to_related_functor_each(P,PP).
   60to_related_functor(P,PP):- compound_name_arguments(P,F,[A,B,C|_]),!,
   61  (to_related_functor_each(F,PP);to_related_functor(A,PP);to_related_functor(B,PP);to_related_functor(C,PP)).
   62to_related_functor(P,PP):- compound_name_arguments(P,F,[]),!,(to_related_functor_each(F,PP)).
   63to_related_functor(P,PP):- compound_name_arguments(P,F,[A]),!,(to_related_functor_each(F,PP);to_related_functor(A,PP)).
   64to_related_functor(P,PP):- compound_name_arguments(P,F,[A,B]),!,(to_related_functor_each(F,PP);to_related_functor(A,PP);to_related_functor(B,PP)).
   65
   66
   67
   68to_related_functor_each(P,_):- \+ atom(P),!,fail.
   69to_related_functor_each(P,PP):- to_related_functor_each1(P,PP).
   70to_related_functor_each(P,PP):- to_related_functor_each1(P,PPP),to_related_functor_each0(PPP,PP).
   71
   72to_related_functor_each1(P,P).
   73to_related_functor_each1(P,PP):- downcase_atom(P,PP),PP\==P.
   74
   75to_related_functor_each0(P,PP):-atom_concat('f_',PP,P).
   76to_related_functor_each0(P,PP):-atom_concat('u_',PP,P).
   77to_related_functor_each0(P,PP):-atom_concat('mf_',PP,P).
   78
   79print_related_clauses(ExceptFor,_OModule,P):-
   80 ignore((
   81   no_repeats(clauses_related(_Module,P,H,B,PrintKeyRef)),
   82   PC = (H :- B),   
   83   nb_holder_value(ExceptFor,Printed),
   84   \+ member(PrintKeyRef,Printed),
   85   nb_holder_append(ExceptFor,PrintKeyRef),
   86   once(print_clause_plain(PC)),
   87   fail)).
   88
   89
   90make_pretty(I,O):- !,notrace((shrink_lisp_strings(I,O), pretty1(O),pretty2(O),pretty3(O))).
   91%make_pretty(I,O):- is_user_output,!,shrink_lisp_strings(I,O), pretty1(O),pretty2(O),pretty3(O).
   92%make_pretty(I,O):- I=O, pretty1(O),pretty2(O),pretty3(O).
   93
   94print_clause_plain(I):-
   95  current_prolog_flag(color_term, Was),
   96  make_pretty(I,O),
   97    setup_call_cleanup(set_prolog_flag(color_term, false),
   98     (nl,lcolormsg1((O))),
   99     set_prolog_flag(color_term, Was)).
  100
  101
  102lcolormsg1(Msg):- mesg_color(Msg,Ctrl),!,ansicall_maybe(Ctrl,fmt9(Msg)).
  103
  104% print_clause_plain(C):- portray_clause_w_vars(O).
  105
  106
  107may_debug_var(_,_,V):- nonvar(V),!.
  108may_debug_var(_,_,V):- variable_name(V,_),!.
  109may_debug_var(L,_,_):- upcase_atom(L,L),!.
  110may_debug_var(L,R,V):- atom(L),atom_concat('f_',LL,L),may_debug_var(LL,R,V).
  111may_debug_var(L,R,V):- atomic_list_concat([_A1,A2,A3|AS],'_',L),atomic_list_concat([A2,A3|AS],'_',LL),may_debug_var(LL,R,V).
  112may_debug_var(L,R,V):- debug_var([L,R],V).
  113
  114may_debug_var(_,V):- nonvar(V),!.
  115may_debug_var(_,V):- variable_name(V,_),!.
  116may_debug_var(R,V):- debug_var(R,V).
  117
  118pretty1(H):- \+ compound(H),!.
  119pretty1(as_rest(Name, Rest, _)):- may_debug_var(Name,Rest).
  120pretty1(get_var(Env, Name, Val)):- may_debug_var('GEnv',Env),may_debug_var(Name,Val).
  121pretty1(deflexical(Env,_Op, Name, Val)):- may_debug_var('SEnv',Env),may_debug_var(Name,Val).
  122pretty1(set_var(Env,Name, Val)):- may_debug_var('SEnv',Env),may_debug_var(Name,Val).
  123
  124pretty1(f_slot_value(_Env, Name, Val)):- may_debug_var(slot,Name,Val).
  125%pretty1(get_kw(ReplEnv, RestNKeys, test, test, f_eql, true, True)
  126pretty1(Env=[List|_]):- compound(List),var(Env),List=[H|_],compound(H),H=bv(_,_), may_debug_var('Env',Env),
  127  maplist(pretty1,List).
  128pretty1(Env=List):- compound(List),var(Env),List=[H|_],compound(H),H=bv(_,_), may_debug_var('Env',Env),
  129  maplist_not_tail(pretty1,List).
  130pretty1(P):- P=..[_,_|List],append(_,[Name, Val|_],List),atom(Name),var(Val),may_debug_var(Name,Val).
  131pretty1(debug_var(R,V)):- may_debug_var(R,V).
  132pretty1(bv(R,V)):- may_debug_var(R,V).
  133pretty1(H):-H=..[_|ARGS],must_maplist_det(pretty1,ARGS).
  134
  135
  136maplist_not_tail(_,ArgS):- var(ArgS),!.
  137maplist_not_tail(G,[X|ArgS]):-call(G,X),maplist_not_tail(G,ArgS).
  138
  139pretty2(H):- \+ compound(H),!. % may_debug_var(F,'_Call',H).
  140%pretty2([H|T]):-!,maplist_not_tail(pretty2,[H|T]).
  141pretty2(H):-  
  142 always((functor(H,F,A),
  143   H=..[F,P1|ARGS],   
  144   (A>1 -> may_debug_var(F,'_Param',P1) ; true),
  145   must_maplist_det(pretty2,[P1|ARGS]))),!. 
  146
  147pretty3(H):- \+ compound(H),!. % may_debug_var(F,'_Call',H).
  148pretty3(H):-pretty4(H),pretty5(H).
  149
  150pretty4(H):- \+ compound(H),!. % may_debug_var(F,'_Call',H).
  151%pretty4([H|T]):-!,maplist_not_tail(pretty4,[H|T]).
  152pretty4(H):-  
  153 ignore(((functor(H,F,_),
  154  wl:init_args(N,F),integer(N),
  155   A is N + 1,   
  156   arg(A,H,R),may_debug_var('KeysNRest',R)))),
  157   H=..[F,P1|ARGS],  
  158   must_maplist_det(pretty4,[P1|ARGS]),!. 
  159
  160pretty5(H):- \+ compound(H),!. % may_debug_var(F,'_Call',H).
  161pretty5([H | B]):- pretty5(H),pretty5(B),may_debug_var('CAR',H),may_debug_var('CDR',B).
  162pretty5(H):-  
  163 always((functor(H,F,A),
  164   H=..[F,P1|ARGS],   
  165   arg(A,H,R),may_debug_var(F,'_Ret',R),   
  166   nop(may_debug_var(F,'_Param',P1)),
  167   must_maplist_det(pretty5,[P1|ARGS]))),!. 
  168
  169
  170:- fixup_exports.