home *** CD-ROM | disk | FTP | other *** search
/ GEMini Atari / GEMini_Atari_CD-ROM_Walnut_Creek_December_1993.iso / files / language / sbprolog / _preproc.p < prev    next >
Encoding:
Text File  |  1993-10-23  |  11.4 KB  |  350 lines
  1. /************************************************************************
  2. *                                    *
  3. * The SB-Prolog System                            *
  4. * Copyright SUNY at Stony Brook, 1986; University of Arizona, 1987    *
  5. *                                    *
  6. ************************************************************************/
  7.  
  8. /*-----------------------------------------------------------------
  9. SB-Prolog is distributed in the hope that it will be useful,
  10. but WITHOUT ANY WARRANTY.  No author or distributor
  11. accepts responsibility to anyone for the consequences of using it
  12. or for whether it serves any particular purpose or works at all,
  13. unless he says so in writing.  Refer to the SB-Prolog General Public
  14. License for full details.
  15.  
  16. Everyone is granted permission to copy, modify and redistribute
  17. SB-Prolog, but only under the conditions described in the
  18. SB-Prolog General Public License.   A copy of this license is
  19. supposed to have been given to you along with SB-Prolog so you
  20. can know your rights and responsibilities.  It should be in a
  21. file named COPYING.  Among other things, the copyright notice
  22. and this notice must be preserved on all copies. 
  23. ------------------------------------------------------------------ */
  24. /* $preprocess1.P */
  25.  
  26. /*   "preprocess0" effects a source-to-source translation of predicates whose
  27.       clauses contain cuts, negations etc.                   */
  28.  
  29. /* **********************************************************************
  30. $preprocess1_export([$preprocess0/3]).
  31.  
  32. $preprocess1_use($translcuts1,[$transl_cuts/5,
  33.             $transl_softcuts/5,$find_prag/4]).
  34. $preprocess1_use($tindex1,[$tindex/2]).
  35. $preprocess1_use($aux1,[_,_,_,_,_,_,_,_,$logical_or/3]).
  36. $preprocess1_use($cond1,[_,$get_test/3,$complementary/3,_]).
  37. $preprocess1_use($meta,[$functor/3,$univ/2,$length/2]).
  38. $preprocess1_use($compare,['$=='/2,_,_,_,_,_,_]).
  39. ********************************************************************** */
  40.  
  41.  
  42. $preprocess0(PredDef,PragList,[NPredDefs]) :-
  43.     PredDef = pred(P,N,CFlag,CutFlag,Clauses),
  44.     $process_cpyflags(Clauses,CFlag,CutFlag),
  45.     (
  46.      (CFlag =:= 0,
  47.       $find_prag(P,N,PragList,Prag),
  48.       $tindex(pred(P,N,CFlag,CutFlag,Clauses,Prag),NPredDefs)
  49.      ) ;
  50.      (CFlag =\= 0, $preprocess1(PredDef,PragList,NPredDefs))
  51.     ).
  52.  
  53. $preprocess1(Pred,PragList,[NPred]) :-
  54.    Pred = pred(P,N,0,C,Clauses), NPred = pred(P,N,0,C,Clauses,Prag),
  55.    $find_prag(P,N,PragList,Prag).
  56. $preprocess1(pred(P,N,1,0,Clauses),PragList,NPred) :-
  57.    $find_prag(P,N,PragList,Prag),
  58.    $preprocess_transform0(P,N,Clauses,NClauses),
  59.                        /* no cuts, but needs processing */
  60.    $tindex(pred(P,N,1,0,NClauses,Prag),NPred).
  61. $preprocess1(pred(P,N,1,1,Clauses),PragList,NPredDefs) :-
  62.    $transl_cuts(P,N,Clauses,PragList,NPredDefs).  /* predicate has cuts */
  63.  
  64. :- index($preprocess_transform0,4,3).
  65.  
  66. $preprocess_transform0(_,_,[],[]).
  67. $preprocess_transform0(P,N,[Fact|Rest],[Fact|NRest]) :-
  68.     Fact = fact(F,C),
  69.     $preprocess_transform0(P,N,Rest,NRest).
  70. $preprocess_transform0(P,N,[Rule|Rest],[NRule|NRest]) :-
  71.     Rule = rule(H,B,CFlag,CRest),
  72.     (
  73.      (CFlag =:= 1, $transl_softcuts(P,N,B,NB,0),
  74.       NRule = rule(H,NB,CFlag,CRest)) ;
  75.      (CFlag =\= 1, NRule = Rule)
  76.     ),
  77.     (
  78.      (CRest =:= 1, $preprocess_transform0(P,N,Rest,NRest)) ;
  79.      (CRest =\= 1, Rest = NRest)
  80.     ).
  81.  
  82.  
  83. $process_cpyflags([],X,Y) :- (X = 0 ; X = 1), (Y = 0 ; Y = 1), !.
  84. $process_cpyflags([fact(_,CFlag)|CRest],CFlag,CutFlag) :-
  85.     $process_cpyflags(CRest,CFlag,CutFlag).
  86. $process_cpyflags([rule(H,B,CFlag0,CFlag1)|CRest],CFlag,CutFlag) :-
  87.     $process_cpyflags_1(B,CFlag0,CutFlag0),
  88.     $process_cpyflags(CRest,CFlag1,CutFlag1),
  89.     $logical_or(CFlag0,CFlag1,CFlag),
  90.     $logical_or(CutFlag0,CutFlag1,CutFlag).
  91.  
  92. $process_cpyflags_1(V,1,0) :- var(V), !.
  93. $process_cpyflags_1(','(G1,G2),CFlag,CutFlag) :- 
  94.     !,
  95.     $process_cpyflags_1(G1,CFlag0,CutFlag0),
  96.     ((CutFlag0 =:= 1, CFlag = 1, CutFlag = 1) ;
  97.      (CutFlag0 =\= 1, $process_cpyflags_1(G2,CFlag1,CutFlag), $logical_or(CFlag0,CFlag1,CFlag))
  98.     ).
  99. $process_cpyflags_1('->'(G1,G2),1,0) :- !.       /* cuts in -> are soft */
  100. $process_cpyflags_1(';'('->'(T,G1),G2),1,0) :- !.   /* cuts in -> are soft */
  101. $process_cpyflags_1(';'(G1,G2),1,CutFlag) :-
  102.     $get_test(G1,T1,_), $get_test(G2,T2,_),
  103.     $univ(T1,[Op1 | Args1]), $univ(T2,[Op2 | Args2]),
  104.     Args1 == Args2,
  105.     $length(Args1,Arity),
  106.     $complementary(Op1,Arity,Op2),
  107.     !,                    /* if-then-else */
  108.     $process_cpyflags_1(G1,_,CutFlag0),
  109.     ((CutFlag0 =:= 1, CutFlag = 1) ;
  110.      (CutFlag0 =\= 1, $process_cpyflags_1(G2,_,CutFlag))
  111.     ).
  112. $process_cpyflags_1(';'(G1,G2),CFlag,CutFlag) :-
  113.     !,
  114.     $process_cpyflags_1(G1,CFlag0,CutFlag0),
  115.     ((CutFlag0 =:= 1, CFlag = 1, CutFlag = 1) ;
  116.      (CutFlag0 =\= 1, $process_cpyflags_1(G2,CFlag1,CutFlag), $logical_or(CFlag0,CFlag1,CFlag))
  117.     ).
  118. $process_cpyflags_1(not(G),1,0) :- !.        /* cuts in not are soft */
  119. $process_cpyflags_1(G,1,1) :- $functor(G,'!',0), !.
  120. $process_cpyflags_1(call(X),1,0) :- !.
  121. $process_cpyflags_1([_|_], 1, 0) :- !.        /* consult */
  122. $process_cpyflags_1(G,0,0).
  123.  
  124.  
  125. $transl_cuts(P,N,Clauses,PragList,[PredDef1 | PredDefRest]) :-
  126.     $functor(Head,P,N),
  127.     N1 is N + 1,
  128.     $gensym_pred(P,NP),
  129.     $univ(Head,[_|Args]),
  130.     $append(Args,[B],NArgs),
  131.     $univ(NLit,[NP|NArgs]),
  132.     $transl_cut_clauses(NP,Clauses,NewCls),
  133.     ((symtype('_$mode'(_,_,_),MDef), MDef > 0, '_$mode'(P,N,Mode)) ->
  134.          ($append(Mode,[2],NMode),
  135.           assert('_$mode'(NP,N1,NMode))
  136.          ) ;                  /* new pred inherits mode */
  137.          true
  138.     ),
  139.     $find_prag(P,N,PragList,Prag),
  140.     PredDef1 = pred(P,N,1,1,[rule(Head,('_$savecp'(B),NLit),0,0)],Prag),
  141.     PredDef2 = pred(NP,N1,1,1,NewCls,Prag),
  142.     $tindex(PredDef2,PredDefRest).
  143.  
  144. $transl_softcuts(P,N,Call,TCall,NCall) :-
  145.     var(Call) ->
  146.         (
  147.         ((NCall =:= 0, $translcuts_naked_var_msg(P,N)) ;
  148.          (NCall =\= 0)
  149.         ),
  150.         TCall = ('_$savecp'(X), '_$interp'(Call,X))
  151.         ) ;
  152.         $transl_softcuts1(P,N,Call,TCall,NCall).
  153.  
  154. :- mode($transl_softcuts1,5,[c,c,nv,d,d]).
  155. :- index($transl_softcuts1,5,3).
  156.  
  157. $transl_softcuts1(P,N,','(A,B), ','(NA,NB),Call) :- !,
  158.     $transl_softcuts(P,N,A,NA,Call),
  159.     $transl_softcuts(P,N,B,NB,Call).
  160. $transl_softcuts1(P,N,'->'(A,B),NB,Call) :-
  161.     !,
  162.     $transl_cuts_ifthenelse(P,N,A,B,fail,NB,Call).
  163. $transl_softcuts1(P,N,';'('->'(A,B),C),NB,Call) :-
  164.     !,
  165.     $transl_cuts_ifthenelse(P,N,A,B,C,NB,Call).
  166. $transl_softcuts1(P,N,';'(A,B),if_then_else(Test,TP,FP),Call) :-
  167.     $cond(A,B,Test,TP0,FP0),
  168.     !,
  169.     $transl_softcuts(P,N,TP0,TP,Call),
  170.     $transl_softcuts(P,N,FP0,FP,Call).
  171. $transl_softcuts1(P,N,';'(A,B), ';'(NA,NB),Call) :- !,
  172.     $transl_softcuts(P,N,A,NA,Call),
  173.     $transl_softcuts(P,N,B,NB,Call).
  174. $transl_softcuts1(P,N,not(Goal), NewGoal,Call) :- !,
  175.     (
  176.      ($inline_neg(Goal, NewGoal)) ;
  177.      (NewGoal = ('_$savecp'(B),((NegGoal,'_$cutto'(B),fail) ; true)),
  178.       $transl_softcuts(P,N,Goal, NegGoal,Call)
  179.      )
  180.     ).
  181. $transl_softcuts1(P,N,call(Goal),NewGoal,_) :-
  182.     !,
  183.     $transl_softcuts(P,N,Goal,NewGoal,1).
  184. $transl_softcuts1(_,_,L,$consult_list(L), _) :- L = [_|_], !.
  185. $transl_softcuts1(P,N,Goal,Goal,_).
  186.  
  187. :- index($transl_cut_clauses,3,2).
  188.  
  189. $transl_cut_clauses(_,[],[]).
  190. $transl_cut_clauses(P,[C1|CRest],[NC1|NCRest]) :-
  191.     $transl_cut_clauses1(P,C1,NC1),
  192.     $transl_cut_clauses(P,CRest,NCRest).
  193.  
  194. :- mode($transl_cut_clauses1,3,[c,nv,d]).
  195. :- index($transl_cut_clauses1,3,2).
  196.  
  197. $transl_cut_clauses1(P,fact(Fact,CFlag),fact(NewFact,CFlag)) :-
  198.     $univ(Fact,[P1|Args]),
  199.     $append(Args,[_],NArgs),
  200.     $univ(NewFact,[P|NArgs]).
  201. $transl_cut_clauses1(P,rule(H,B,CFlag0,CFlag1),rule(NH,NB,CFlag0,CFlag1)) :-
  202.     $univ(H,[P1|Args]),
  203.     $append(Args,[V],NArgs),
  204.     $univ(NH,[P|NArgs]),
  205.     $transl_hardcuts(P,N,V,B,NB,0).
  206.  
  207. $transl_hardcuts(P,N,V,Call,TCall,NCall) :-
  208.     var(Call) ->
  209.         (
  210.             ((NCall =:= 0, $translcuts_naked_var_msg(P,N)) ;
  211.          (NCall =\= 0)
  212.         ),
  213.         TCall = ('_$savecp'(X), '_$interp'(Call,X))
  214.         ) ;
  215.         $transl_hardcuts1(P,N,V,Call,TCall,NCall).
  216.  
  217. :- mode($transl_hardcuts1,6,[c,c,d,nv,d,d]).
  218. :- index($transl_hardcuts1,6,4).
  219.  
  220. $transl_hardcuts1(P,N,V,','(A1,B1),','(A2,B2),Call) :-
  221.     !,
  222.     $transl_hardcuts(P,N,V,A1,A2,Call),
  223.     $transl_hardcuts(P,N,V,B1,B2,Call).
  224. $transl_hardcuts1(P,N,V,'->'(A,B),NB,Call) :-
  225.     $transl_cuts_ifthenelse(P,N,A,B,fail,NB,Call).
  226. $transl_hardcuts1(P,N,V,';'('->'(A,B),C),NB,Call) :-
  227.     $transl_cuts_ifthenelse(P,N,A,B,C,NB,Call).
  228. $transl_hardcuts1(P,N,V,';'(A1,B1),if_then_else(Test,TP,FP),Call) :-
  229.     $cond(A1,B1,Test,TP0,FP0),
  230.     !,
  231.     $transl_hardcuts(P,N,V,TP0,TP,Call),
  232.     $transl_hardcuts(P,N,V,FP0,FP,Call).
  233. $transl_hardcuts1(P,N,V,';'(A1,B1),';'(A2,B2),Call) :-
  234.     !,
  235.     $transl_hardcuts(P,N,V,A1,A2,Call),
  236.     $transl_hardcuts(P,N,V,B1,B2,Call).
  237. $transl_hardcuts1(P,N,V,not(Goal),NewGoal,Call) :-
  238.     !,
  239.     (
  240.      ($inline_neg(Goal, NewGoal)) ;
  241.      (NewGoal = ('_$savecp'(B),((NegGoal,'_$cutto'(B),fail) ; true)),
  242.       $transl_hardcuts(P,N,B,Goal, NegGoal,Call)
  243.      )
  244.     ).
  245. $transl_hardcuts1(P,N,V,'!','_$cutto'(V),_) :- !.
  246. $transl_hardcuts1(P,N,V,call(Goal),NewGoal,_) :-
  247.     !,
  248.     $transl_hardcuts(P,N,V,Goal,NewGoal,1).
  249. $transl_hardcuts1(_,_,_,L,$consult_list(L), _) :- L = [_|_], !.
  250. $transl_hardcuts1(_,_,_,L,L,_).
  251.  
  252. :- mode($transl_contains_cut,1,[nv]).
  253.  
  254. $transl_contains_cut(X) :- var(X), !, fail.
  255. $transl_contains_cut(','(A,B)) :-
  256.     $transl_contains_cut(A) ;
  257.     $transl_contains_cut(B).
  258. $transl_contains_cut(';'(A,B)) :-
  259.     $transl_contains_cut(A) ;
  260.     $transl_contains_cut(B).
  261. $transl_contains_cut('->'(A,B)) :-
  262.     $transl_contains_cut(A) ;
  263.     $transl_contains_cut(B).
  264. $transl_contains_cut(not(C)) :- $transl_contains_cut(C).
  265. $transl_contains_cut(call(C)) :- $transl_contains_cut(C).
  266. $transl_contains_cut('!').
  267.  
  268. $translcuts_naked_var_msg(P,N) :-
  269.     $umsg(['*** Warning: naked variable being called in',P,'/',N,'***']).
  270.  
  271. $translcuts_inline_ifthenelse(P,N,A,B,C,NewBody,Call) :-
  272.     (($transl_contains_cut(B), !,
  273.       NewBody = ','('_$savecp'(X),if_then_else(NA,NB0,NC)),
  274.       $transl_hardcuts(P,N,X,A,NA,Call),
  275.       $transl_hardcuts(P,N,X,B,NB0,Call),
  276.       $transl_hardcuts(P,N,X,C,NC,Call)
  277.      ) ;
  278.      (NewBody = if_then_else(NA,NB0,NC),
  279.       $transl_softcuts(P,N,A,NA,Call),
  280.       $transl_softcuts(P,N,B,NB0,Call),
  281.       $transl_softcuts(P,N,C,NC,Call)
  282.      )
  283.     ).
  284.  
  285. $transl_cuts_ifthenelse(P,N,A,B,C,NB,Call) :-
  286.     $transl_all_inlines(A),
  287.     $translcuts_inline_ifthenelse(P,N,A,B,C,NB,Call).
  288. $transl_cuts_ifthenelse(P,N,A,B,C,NB,Call) :-
  289.     NB = ','('_$savecp'(X),';'((T1,'_$cutto'(X),NB0),NC)),
  290.     $transl_hardcuts(P,N,X,A,T1,Call),
  291.     $transl_hardcuts(P,N,X,B,NB0,Call),
  292.     $transl_hardcuts(P,N,X,C,NC,Call).
  293.  
  294. /*  at this point, a test is considered to be inline (and hence a candidate
  295.     for transformation to "if-then-else" iff it is either an inline test,
  296.     or a conjunction of inline tests, or a disjunction of inline tests.
  297.     We could set it up so that arbitrary constructs involving inlines are
  298.     allowed, but this complicates code generation quite a bit, and it's not
  299.     clear that more complex constructs are encountered frequently in
  300.     practice.                                  */
  301.  
  302. $transl_all_inlines(','(G1,G2)) :-
  303.     !,
  304.     $transl_all_inlines_conj(G1),
  305.     $transl_all_inlines_conj(G2).
  306. $transl_all_inlines(';'(G1,G2)) :-
  307.     !,
  308.     $transl_all_inlines_disj(G1),
  309.     $transl_all_inlines_disj(G2).
  310. $transl_all_inlines(A) :-
  311.     $functor(A,Pred,Arity),
  312.     $inline_test(Pred,Arity).
  313.  
  314. $transl_all_inlines_conj(','(G1,G2)) :-
  315.     !,
  316.     $transl_all_inlines_conj(G1),
  317.     $transl_all_inlines_conj(G2).
  318. $transl_all_inlines_conj(A) :-
  319.     $functor(A,Pred,Arity),
  320.     $inline_test(Pred,Arity).
  321.  
  322. $transl_all_inlines_disj(';'(G1,G2)) :-
  323.     !,
  324.     $transl_all_inlines_disj(G1),
  325.     $transl_all_inlines_disj(G2).
  326. $transl_all_inlines_disj(A) :-
  327.     $functor(A,Pred,Arity),
  328.     $inline_test(Pred,Arity).
  329.  
  330.  
  331. $find_prag(P,N,PragList,Prag) :- $member(prag(P,N,Prag),PragList), !.
  332. $find_prag(_,_,_,[]).
  333.  
  334.  
  335. :- mode($inline_test,2,[c,c]).
  336.  
  337. $inline_test('>',2).
  338. $inline_test('>=',2).
  339. $inline_test('=<',2).
  340. $inline_test('<',2).
  341. $inline_test('=:=',2).
  342. $inline_test('=\=',2).
  343. $inline_test(var,1).
  344. $inline_test(nonvar,1).
  345. $inline_test(true,0).
  346. $inline_test(integer,1).
  347.  
  348. /* --------------------------- $preprocess1.P --------------------------- */
  349.  
  350.