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
   89print_clause_plain(I):-
   90  (current_prolog_flag(color_term, Was);Was=[]),!,
   91  make_pretty(I,O),
   92    setup_call_cleanup(set_prolog_flag(color_term, false),
   93     (nl,lcolormsg1((O))),
   94     set_prolog_flag(color_term, Was)).
   95
   96
   97lcolormsg1(Msg):- mesg_color(Msg,Ctrl),!,ansicall_maybe(Ctrl,fmt9(Msg)).
   98
   99% print_clause_plain(C):- portray_clause_w_vars(O).
  100
  101
  102
  103make_pretty(I,O):- !,call_each(must_or_rtrace,(shrink_lisp_strings(I,M), pretty_numbervars(M,O))).
  104%make_pretty(I,O):- is_user_output,!,shrink_lisp_strings(I,O), pretty1(O),pretty2(O),pretty3(O).
  105%make_pretty(I,O):- I=O, pretty1(O),pretty2(O),pretty3(O).
  106
  107%maplist_not_tail(_,ArgS):- var(ArgS),!.
  108%maplist_not_tail(G,[X|ArgS]):-call(G,X),maplist_not_tail(G,ArgS).
  109
  110
  111
  112
  113/*
  114may_debug_var(_,_,V):- nonvar(V),!.
  115may_debug_var(_,_,V):- variable_name(V,_),!.
  116may_debug_var(L,_,_):- upcase_atom(L,L),!.
  117may_debug_var(L,R,V):- atom(L),atom_concat('f_',LL,L),may_debug_var(LL,R,V).
  118may_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).
  119may_debug_var(L,R,V):- debug_var([L,R],V).
  120
  121may_debug_var(_,V):- nonvar(V),!.
  122may_debug_var(_,V):- variable_name(V,_),!.
  123may_debug_var(R,V):- debug_var(R,V).
  124
  125pretty1(H):- \+ compound(H),!.
  126pretty1(as_rest(Name, Rest, _)):- may_debug_var(Name,Rest).
  127pretty1(get_var(Env, Name, Val)):- may_debug_var('GEnv',Env),may_debug_var(Name,Val).
  128pretty1(deflexical(Env,_Op, Name, Val)):- may_debug_var('SEnv',Env),may_debug_var(Name,Val).
  129pretty1(set_var(Env,Name, Val)):- may_debug_var('SEnv',Env),may_debug_var(Name,Val).
  130
  131pretty1(f_slot_value(_Env, Name, Val)):- may_debug_var(slot,Name,Val).
  132%pretty1(get_kw(ReplEnv, RestNKeys, test, test, f_eql, true, True)
  133pretty1(Env=[List|_]):- compound(List),var(Env),List=[H|_],compound(H),H=bv(_,_), may_debug_var('Env',Env),
  134  maplist(pretty1,List).
  135pretty1(Env=List):- compound(List),var(Env),List=[H|_],compound(H),H=bv(_,_), may_debug_var('Env',Env),
  136  maplist_not_tail(pretty1,List).
  137pretty1(P):- P=..[_,_|List],append(_,[Name, Val|_],List),atom(Name),var(Val),may_debug_var(Name,Val).
  138pretty1(debug_var(R,V)):- may_debug_var(R,V).
  139pretty1(bv(R,V)):- may_debug_var(R,V).
  140pretty1(H):-H=..[_|ARGS],must_maplist_det(pretty1,ARGS).
  141
  142
  143pretty2(H):- \+ compound(H),!. % may_debug_var(F,'_Call',H).
  144%pretty2([H|T]):-!,maplist_not_tail(pretty2,[H|T]).
  145pretty2(H):-  
  146 always((functor(H,F,A),
  147   H=..[F,P1|ARGS],   
  148   (A>1 -> may_debug_var(F,'_Param',P1) ; true),
  149   must_maplist_det(pretty2,[P1|ARGS]))),!. 
  150
  151pretty3(H):- \+ compound(H),!. % may_debug_var(F,'_Call',H).
  152pretty3(H):-pretty4(H),pretty5(H).
  153
  154pretty4(H):- \+ compound(H),!. % may_debug_var(F,'_Call',H).
  155%pretty4([H|T]):-!,maplist_not_tail(pretty4,[H|T]).
  156pretty4(H):-  
  157 ignore(((functor(H,F,_),
  158  wl:init_args(N,F),integer(N),
  159   A is N + 1,   
  160   arg(A,H,R),may_debug_var('KeysNRest',R)))),
  161   H=..[F,P1|ARGS],  
  162   must_maplist_det(pretty4,[P1|ARGS]),!. 
  163
  164pretty5(H):- \+ compound(H),!. % may_debug_var(F,'_Call',H).
  165pretty5([H | B]):- pretty5(H),pretty5(B),may_debug_var('CAR',H),may_debug_var('CDR',B).
  166pretty5(H):-  
  167 always((functor(H,F,A),
  168   H=..[F,P1|ARGS],   
  169   arg(A,H,R),may_debug_var(F,'_Ret',R),   
  170   nop(may_debug_var(F,'_Param',P1)),
  171   must_maplist_det(pretty5,[P1|ARGS]))),!. 
  172
  173*/
  174:- fixup_exports.