home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / lifeos2.zip / LIFE-1.02 / TOOLS / DEBUG.EXP < prev    next >
Text File  |  1996-06-04  |  6KB  |  90 lines
  1. %    $Id: debug.exp,v 1.2 1994/12/08 23:50:06 duchier Exp $    
  2. module("debug")?
  3.  
  4. public(debug,undebug,goal)?
  5.  
  6. :-(debug(_A,_B,_C),,(=(_B,{clause;fail;goal}),,(!,,(=(_C,{true;false}),,(!,,(;(,(is_function(_A),,(!,,(=(_D,->),,(=(_E,function),=(_F,rewrite_func))))),;(,(is_predicate(_A),,(!,,(=(_D,:-),,(=(_E,predicate),=(_F,rewrite_pred))))),,(write_err("Debug: ",_A," is not a predicate or a function"),,(nl,fail)))),,(dynamic(_A),,(;(,(get_old_clauses(_A,_G),!),,(read_and_retract(_A,_G,_D),assert(old_clauses(_A,_G,_D,_E)))),;(,(:==(_G,[]),,(!,,(write_err("*** No clauses for '",_A,"'"),nl_err))),,(write("Added debugging code to ",_E," '",_A,"': level=",_B,", verbose=",_C,", clauses=",length(_G)),,(nl,,(=(_F,@(_G,_A,_B,_C)),_F)))))))))))).
  7.  
  8. :-(undebug(_A),,(get_old_clauses(_A,_B),,(!,,(assert_list(_B),retract(:-(old_clauses(_A),succeed)))))).
  9.  
  10. :-(undebug(_A),,(write("Debug: no stored clauses for ",_A),nl)).
  11.  
  12. :-(assert_list([_A|_B]),,(!,,(assert(_A),assert_list(_B)))).
  13.  
  14. assert_list([]).
  15.  
  16. dynamic(old_clauses)?
  17.  
  18. :-(get_old_clauses(_A,_B),,(clause(:-(old_clauses(_A,_B,_C,_D),succeed)),,(!,,(write("Debug: restored original clauses for ",_D," '",_A,"'"),,(nl,read_and_retract(_A,@,_C)))))).
  19.  
  20. :-(prefix(_A),write("<",_A,"> ")).
  21.  
  22. :-(debug_indent(0),!).
  23.  
  24. :-(debug_indent(_A),,(write("  "),debug_indent(-(_A,1)))).
  25.  
  26. ->(write_term(_A,_B),cond(_B,_A,root_sort(_A))).
  27.  
  28. :-(read_and_retract(_A,[_B|_C],_D),,(=(_E,root_sort(_A)),,(=(_B,root_sort(_D)),,(=(.(_B,1),_E),,(=(.(_B,2),@),,(clause(_B),,(!,,(retract(_B),read_and_retract(_A,_C,_D))))))))).
  29.  
  30. read_and_retract(@,[],@).
  31.  
  32. :-(rewrite_pred(_A,_B,_C,_D),,(cond(:\==(_C,fail),call_pred(_B,_D)),,(rewrite_clauses(_A,_B,_C,_D,1),,(fail_pred(_B,_D),!)))).
  33.  
  34. :-(rewrite_pred(@,_A,@,@),,(write_err("*** Debug failed for '",_A,"': program corrupted."),nl_err)).
  35.  
  36. :-(call_pred(_A,_B),,(=(_C,root_sort(_A)),,(=(_D,write_term(_C,_B)),assert(:-(_C,,(prefix("CALL"),,(write(_D,": entry call"),,(nl,fail)))))))).
  37.  
  38. :-(fail_pred(_A,_B),,(=(_C,root_sort(_A)),,(=(_D,write_term(_C,_B)),assert(:-(_C,,(prefix("FAIL"),,(write(_D,": fails"),,(nl,fail)))))))).
  39.  
  40. :-(rewrite_clauses([_A|_B],_C,_D,_E,_F),,(!,,(=(_A,:-(_G,_H)),,(cond(:\==(_D,fail),try_clause(_C,_F)),,(rewrite_body(_H,_I,_C,_D,_E,_F,1),,(cond(:==(_D,fail),=(_J,_I),=(_J,,(_I,,(prefix("SUCC"),,(write(_C,"#",_F,": succeeds"),nl))))),,(assert(:-(_G,_J)),rewrite_clauses(_B,_C,_D,_E,+(_F,1))))))))).
  41.  
  42. rewrite_clauses([],@,@,@,@).
  43.  
  44. :-(try_clause(_A,_B),,(=(_C,root_sort(_A)),cond(>(_B,1),assert(:-(_A,,(prefix("REDO"),,(write(_C,": try clause #",_B),,(nl,fail)))))))).
  45.  
  46. non_strict(rewrite_body)?
  47.  
  48. :-(rewrite_body(_A,_A,@,@,@,@,@),,(:==(_A,@),!)).
  49.  
  50. :-(rewrite_body(,(_A,_B),,(_C,_D),_E,_F,_G,_H,_I),,(!,,(rewrite_body(_A,_C,_E,_F,_G,_H,_I),,(=(_J,+(_I,1)),rewrite_body(_B,_D,_E,_F,_G,_H,_J))))).
  51.  
  52. :-(rewrite_body(;(_A,_B),;(_C,_D),_E,_F,_G,_H,_I),,(!,,(rewrite_body(_A,_C,_E,_F,_G,_H,_I),,(rewrite_body(_B,_J,_E,_F,_G,_H,_I),cond(:==(_F,goal),=(_D,,(prefix("REDO"),,(write(_E,"#",_H,": retry disjunction"),,(nl,_J)))),=(_D,_J)))))).
  53.  
  54. :-(rewrite_body(!,_A,_B,_C,@,_D,_E),,(!,=(_A,,(!,;(cond(:==(_C,fail),succeed,,(prefix("CUT!"),,(cond(:==(_C,goal),write(_B,"#",_D,".",_E,": cut!"),write(_B,"#",_D,": cut!")),nl))),,(prefix("FAIL"),,(write(_B,"#",_D,": fails and alternatives cut"),,(nl,fail)))))))).
  55.  
  56. :-(rewrite_body(_A: cond(_B),_C: cond(_B),_D,_E,_F,_G,_H),,(!,,(cond(has_feature(2,_A,_I),,(rewrite_body(_I,@,_D,_E,_F,_G,_H),=(.(_C,2),_I))),cond(has_feature(3,_A,_J),,(rewrite_body(_J,@,_D,_E,_F,_G,_H),=(.(_C,3),_J)))))).
  57.  
  58. :-(rewrite_body(_A,_B,_C,_D,_E,_F,_G),cond(:==(_D,goal),=(_B,,(prefix("GOAL"),,(write(_C,"#",_F,".",_G,": ",write_term(_A,_E)),,(nl,_A)))),=(_B,_A))).
  59.  
  60. :-(rewrite_func(_A,_B,_C,_D),,(rewrite_rules(_A,_B,_C,_D,1),,(fail_func(_B,_D),!))).
  61.  
  62. :-(rewrite_func(@,_A,@,@),,(write_err("*** Debug failed for '",_A,"': program corrupted."),nl_err)).
  63.  
  64. :-(fail_func(_A,_B),,(=(_C,root_sort(_A)),,(=(_D,write_term(_C,_B)),assert(->(_C,|(@,,(prefix("FAIL"),,(write(_D,": fails"),,(nl,fail))))))))).
  65.  
  66. :-(rewrite_rules([_A|_B],_C,_D,_E,_F),,(!,,(rewrite_rule(_A,_C,_D,_E,_F),rewrite_rules(_B,_C,_D,_E,+(_F,1))))).
  67.  
  68. rewrite_rules([],@,@,@,@).
  69.  
  70. :-(func_fail(_A,_B),,(prefix("FAIL"),,(write(_A,": fails at clause #",_B),,(nl,fail)))).
  71.  
  72. :-(eval_fail(_A,_B),,(prefix("FAIL"),,(write(_A,": evaluation at clause #",_B),,(nl,fail)))).
  73.  
  74. :-(body_fail(_A,_B),,(prefix("FAIL"),,(write(_A,": such-that goals at clause #",_B),,(nl,fail)))).
  75.  
  76. non_strict(rewrite_rule)?
  77.  
  78. :-(rewrite_rule(->(_A,_B),_C,goal,_D,_E),,(:==(_B,`(|)),,(!,,(=(_B,`(|(_F,_G))),,(=(_H,write_term(_A,_D)),,(rewrite_body(_G,_I,_C,goal,_D,_E,1),,(=(_J,,(<<-(_K,@),;(,(prefix("PATT"),,(write(_H,": pattern matches clause #",_E),,(nl,,(<<-(_K,patt),,(=(_L,_F),,(prefix("EVAL"),,(write(_H,": clause #",_E,", result=",`(write_term(_L,_D))),,(nl,,(<<-(_K,evall),,(_I,,(prefix("SUCC"),,(write(_H,": clause #",_E),,(nl,<<-(_K,succ)))))))))))))),;(,(`(:==(_K,succ)),,(!,fail)),;(,(`(:==(_K,evall)),,(!,body_fail(_H,_E))),;(,(`(:==(_K,patt)),,(!,eval_fail(_H,_E))),func_fail(_H,_E))))))),assert(->(_A,|(_L,_J)))))))))).
  79.  
  80. :-(rewrite_rule(->(_A,_B),@,goal,_C,_D),,(!,,(=(_E,write_term(_A,_C)),,(=(_F,,(<<-(_G,@),;(,(prefix("PATT"),,(write(_E,": pattern matches clause #",_D),,(nl,,(<<-(_G,patt),,(=(_H,_B),,(prefix("EVAL"),,(write(_E,": clause #",_D,", result=",`(write_term(_H,_C))),,(nl,<<-(_G,evall))))))))),;(,(`(:==(_G,evall)),,(!,fail)),;(,(`(:==(_G,patt)),,(!,eval_fail(_E,_D))),func_fail(_E,_D)))))),assert(->(_A,|(_H,_F))))))).
  81.  
  82. :-(rewrite_rule(->(_A,_B),@,clause,_C,_D),,(:==(_B,`(|)),,(!,,(=(_B,`(|(_E,_F))),,(=(_G,write_term(_A,_C)),,(=(_H,_E),,(=(_I,,(<<-(_J,@),;(,(_F,,(prefix("SUCC"),,(write(_G,": clause #",_D,", result=",`(write_term(_H,_C))),,(nl,<<-(_J,succ))))),;(,(`(:==(_J,succ)),,(!,fail)),func_fail(_G,_D))))),assert(->(_A,|(_H,_I)))))))))).
  83.  
  84. :-(rewrite_rule(->(_A,_B),@,clause,_C,_D),,(!,,(=(_E,write_term(_A,_C)),,(=(_F,_B),,(=(_G,,(<<-(_H,@),;(,(prefix("EVAL"),,(write(_E,": clause #",_D,", result=",`(write_term(_F,_C))),,(nl,<<-(_H,evall)))),;(,(`(:==(_H,evall)),,(!,fail)),func_fail(_E,_D))))),assert(->(_A,|(_F,_G)))))))).
  85.  
  86. :-(rewrite_rule(->(_A,_B),@,fail,_C,_D),,(:==(_B,`(|)),,(!,,(=(_B,`(|(_E,_F))),,(=(_G,write_term(_A,_C)),,(=(_H,,(<<-(_I,@),;(,(_F,<<-(_I,succ)),,(`(:==(_I,@)),func_fail(_G,_D))))),assert(->(_A,|(_E,_H))))))))).
  87.  
  88. :-(rewrite_rule(->(_A,_B),@,fail,_C,_D),,(!,,(=(_E,write_term(_A,_C)),,(=(_F,,(<<-(_G,@),;(<<-(_G,succ),,(`(:==(_G,@)),func_fail(_E,_D))))),assert(->(_A,|(_B,_F))))))).
  89.  
  90.