home *** CD-ROM | disk | FTP | other *** search
/ GEMini Atari / GEMini_Atari_CD-ROM_Walnut_Creek_December_1993.iso / files / language / sbprolog / _mac.p < prev    next >
Encoding:
Text File  |  1993-10-23  |  12.8 KB  |  383 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.  
  25.  
  26. /* This file contains code that supports a macro facility for Prolog.
  27. Its exported  predicate is  $macexp which  takes a  list of predicate
  28. definitions constructed by $getclauses and produces another such list
  29. with  macros  expanded.    Its  basic  mechanism is  a simple partial
  30. evaluator.  It is to be called by $consult and $compile.
  31.  
  32. `Macros', or predicates to be evaluated at compile-time, are defined 
  33. in a predicate ::-(Head,Body), where facts have `true' as their body.
  34. For easy input, the following addition to the read op-table can be made:
  35.     assert($read_curr_op(1200,xfx,('::-'))).
  36. so then macro clauses can be input to look very much like regular
  37. clauses (except that facts need a `true' body.)
  38.  
  39. The  partial  evaluator  will  expand  any  deterministic  call  to a
  40. predicate with a definition in ::-/2. A call is deterministic if it
  41. unifies with the head of only one clause in ::-/2. If a call is not
  42. deterministic, it will not be expanded. Notice that this is not a
  43. fundamental restriction, since `;' is permitted in the body of a
  44. clause. 
  45.  
  46. The  partial  evaluator  is  actually  a  Prolog  interpreter written
  47. `purely'  in  Prolog,  i.e.,  variable   assignments  are  explicitly
  48. handled.  This is necessary  to be  able to  handle impure constructs
  49. such  as  `var(X),X=a'.    As  a  result this  is a  VERY SLOW Prolog
  50. evaluator.  
  51.  
  52. Since  the partial  evaluator can  be put  into an  infinite loop, it
  53. maintains a depth-bound  and will  not expand  recursive calls deeper
  54. than  that.    The  depth  is  determined by  the globalset predicate
  55. $mac_depth.  */
  56.  
  57. $mac_export([$macexp/3]).
  58.  
  59. /* $mac_use($blist,[$append/3,$member/2,$memberchk/2]).
  60.    $mac_use($bio,[$writename/1,$writeqname/1,$put/1,$nl/0,$tab/1,
  61.     $tell/1,$tell/2,$telling/1,$told/0,$get/1,$get0/1,$see/1,$seeing/1,
  62.     $seen/0]).
  63.    $mac_use($inlines,['='/2,'<'/2,'=<'/2,'>='/2,'>'/2,'=:='/2,
  64.     '=\='/2,is/2,eval/2,'_$savecp'/1,'_$cutto'/1,var/1,nonvar/1,
  65.     fail/0,true/0,halt/0]).
  66.    $mac_use($setof,[$setof/3,$bagof/3,$findall/3,$sort/2,$keysort/3]).
  67.    $mac_use($meta,[$functor/3,$univ/2,$length/2]).
  68.    $mac_use($bmeta,[$atom/1,$atomic/1,$integer/1,$number/1,$structure/1,
  69.     $functor0/2,$bldstr/3,$arg/3,$arity/2,$real/1,$float/1,_,_]).
  70. */
  71.  
  72. /* $macexp(Clslist,Opts,Expclslist) takes an input list of
  73. predicates Clslist (as produced by $getclauses) and produces another
  74. list, Expclslist, in which macros are expanded. Also the macros are
  75. also converted so as to define equivalent run-time predicates, too.
  76. (e.g., p ::- q. is converted to the clause p :- q.). Opts is an
  77. options list: v: verbose and print that macros are (or are not)
  78. being expanded; e: expand macros; d: dump all clauses after
  79. expanding to user, used for debugging and determining exactly what
  80. the expander did. */
  81.  
  82. $macexp(Clslist,Opts,Expclslist) :-
  83.     $member(pred((::-),2,_,_,Dblist),Clslist) ->
  84.      ($member(e,Opts) -> 
  85.        ($member(v,Opts) -> tab(15),write('expanding macros:'),nl;true),
  86.        ($pred_undefined($mac_depth(_)) -> 
  87.         $globalset($mac_depth(50));true),
  88.        $maccvtcls(Dblist,Db),
  89.        $macexpall(Clslist,Nclslist,Db),
  90.        $mactocls(Nclslist,Expclslist),
  91.        ($member(d,Opts) -> $macprintprds(Expclslist);true)
  92.      ;
  93.        ($member(v,Opts) -> tab(15),$writename('Not expanding macros'),$nl;
  94.                 true),
  95.        $mactocls(Clslist,Expclslist)
  96.      )
  97.     ;
  98.     Expclslist=Clslist.
  99.  
  100. /* convert macro db from fact(..) form to ::-(.,.) form */
  101. $maccvtcls([],[]).
  102. $maccvtcls([fact(Cls,_)|R],[Cls|Rp]) :- $maccvtcls(R,Rp).
  103. $maccvtcls([rule(H,B,_,_)|R],Rp) :-
  104.      $telling(Ostr), $tell(stderr),
  105.      $writename('Illegal macro: '),
  106.      $write(H), $write((':-')), $write(B),
  107.      $nl,$maccvtcls(R,Rp).
  108.  
  109.  
  110.  
  111. /* add to end of open-tailed list */
  112. $macmemberadd(X,L) :- var(L),!,L=[X|_].
  113. $macmemberadd(X,[_|L]) :- $macmemberadd(X,L).
  114.  
  115.  
  116. $macmktail(X,L) :- var(L),!,X=L.
  117. $macmktail(X,[_|L]) :- $macmktail(X,L).
  118.  
  119. /* expand macros in every clause */
  120. $macexpall([],[],Db).
  121. $macexpall([P|R],[P|Rp],Db) :- P = pred((::-),_,_,_,_),!,$macexpall(R,Rp,Db).
  122. $macexpall([pred(P,A,X1,X2,Clauselist)|R],
  123.        [pred(P,A,X1,X2,Nclauselist)|Rp],Db) :-
  124.     $macexpall1(Clauselist,Nclauselist,Db),$macexpall(R,Rp,Db).
  125.  
  126. $macexpall1([],[],_).
  127. $macexpall1([fact(Fact,A1)|R],[fact(Fact,A1)|Rp],Db) :- $macexpall1(R,Rp,Db).
  128. $macexpall1([rule(Head,Body,A1,A2)|R],[rule(Head,Nbody,A1,A2)|Rp],Db) :-
  129. /*    $maceximp(Body,Nbody,Db), */
  130.     $macpartevg(Body,Nbody,Db), 
  131.     $macexpall1(R,Rp,Db).
  132.  
  133. /* convert ::- facts to :- rules and facts */
  134. $mactocls([],[]).
  135. $mactocls([pred((::-),2,_,_,Clauses)|Clslist],Nclslist) :- !,
  136.     $mactopred(Clauses,Nclslist),$macmktail(Rem,Nclslist),
  137.     $mactocls(Clslist,Rem).
  138. $mactocls([P|R],[P|Rp]) :- $mactocls(R,Rp).
  139.  
  140. $mactopred([],_).
  141. $mactopred([fact(::-(Head,Body),A1)|More],List) :- !,
  142.     $functor(Head,Fun,Arity),
  143.     $member(pred(Fun,Arity,_,_,Clist),List),!,
  144.     (Body=true -> $macmemberadd(fact(Head,_),Clist);
  145.         $macmemberadd(rule(Head,Body,_,_),Clist)),
  146.     $mactopred(More,List).
  147. $mactopred([rule(::-(Head,Body),Rbody,A1,A2)|More],List) :- !,
  148.     $mactopred(More,List).
  149.  
  150.  
  151. /* $maceximp traverses a body and treats each goal separately. This
  152. is just for efficiency, and is used only at the top level.
  153. partevalgoal could be called directly instead of this. */
  154.  
  155. $maceximp((A,B),(Ea,Eb),D) :- !,$maceximp(A,Ea,D),$maceximp(B,Eb,D).
  156. $maceximp((A->B;C),(Ea->Eb;Ec),D) :- !,$maceximp(A,Ea,D),$maceximp(B,Eb,D),
  157.     $maceximp(C,Ec,D).
  158. $maceximp((A;B),(Ea;Eb),D) :- !,$maceximp(A,Ea,D),$maceximp(B,Eb,D).
  159. $maceximp(not(A),not(Ea),D) :- !,$maceximp(A,Ea,D).
  160. $maceximp(\+(A),\+(Ea),D) :- !,$maceximp(A,Ea,D).
  161. $maceximp(A,Ea,D) :- not(not($member(::-(A,_),D))),!,$macpartevg(A,Ea,D).
  162. $maceximp(A,A,_).
  163.  
  164.  
  165.  
  166. /* This is a Prolog partial evaluator in which ALL variable manipulation is
  167. done explicitly. */
  168.  
  169. $macpartevg(Q,A,Db) :- 
  170.     $mac_depth(N),$macpartev(Q,R,[],V,Db,N),$macpartevp(Q,R,V,A).
  171.  
  172. $macpartevp(Q,R,V,A) :-
  173.     $macgetfreev(Q,Fv),$macgetbnds(Fv,V,Bnd),$macgetfvb(V,Fv,Vfb),
  174.     $macapplyfv(V,Vfb,R,Rp),
  175.     (Bnd=true->A=Rp;(Rp=true->A=Bnd;A=(Rp,Bnd))).
  176.  
  177.  
  178. /*   $macpartev(G,R,Vi,Vo,Db) where G is the goal, R is the result of the 
  179. partial evluation (the residue), V is a list of _V=binding pairs, 
  180. Db is a list of clauses that define what predicates are to be 
  181. evaluated.  */
  182.  
  183. $macpartev(A,B,C,D,E,F) :- /* write(call(A,B)),nl, */
  184.     $macpartev1(A,B,C,D,E,F).
  185.     /* write(exit(A,B)),nl. */
  186.  
  187. $macpartev1((A,B),R,Vi,Vo,Db,N) :- !,$macpartev(A,Ra,Vi,Vm,Db,N),
  188.     (Ra=fail -> R=fail,Vo=Vm;
  189.      Ra=true -> $macpartev(B,R,Vm,Vo,Db,N);
  190.        $macpartev(B,Rb,Vm,Vo,Db,N),(Rb=true -> R=Ra;R=(Ra,Rb))
  191.     ).
  192.  
  193. $macpartev1(true,true,V,V,_,_) :- !.
  194.  
  195. $macpartev1(A,R,Vi,Vo,_,_) :- $macbichk(A,Vi),!,
  196.     $macapplynv(Vi,A,Ag),    /* new variables! */
  197.     ('_$call'(Ag) ->
  198.         $macunify(A,Ag,Vi,Vo),R=true;
  199.         R=fail,Vi=Vo
  200.     ).
  201.  
  202. $macpartev1((A->B;C),R,Vi,Vo,Db,N) :- !,$macpartev(A,Ea,Vi,Vm,Db,N),
  203.     (Ea=true -> $macpartev(B,R,Vm,Vo,Db,N);
  204.      Ea=fail -> $macpartev(C,R,Vi,Vo,Db,N);
  205.          $macpartev(B,Eb,Vm,V1,Db,N),$macpartevp(B,Eb,V1,Ebb),
  206.         $macpartev(C,Ec,Vi,V2,Db,N),$macpartevp(C,Ec,V2,Ecc),
  207.             R=(Ea->Ebb;Ecc),Vo=Vi
  208.     ).
  209.  
  210. $macpartev1((A;B),R,Vi,Vo,Db,N) :- !,
  211.     $macpartev(A,Ea,Vi,V1,Db,N),
  212.     $macpartev(B,Eb,Vi,V2,Db,N),
  213.     (Ea=fail -> R=Eb,Vo=V2;
  214.      Eb=fail -> R=Ea,Vo=V1;
  215.         $macpartevp(A,Ea,V1,Eaa),
  216.         $macpartevp(B,Eb,V2,Ebb),
  217.         R=(Eaa;Ebb),Vo=Vi
  218.     ).
  219.  
  220. $macpartev1(not(A),R,Vi,Vi,Db,N) :- !,$macpartev(A,Ea,Vi,_,Db,N),
  221.     (Ea=true -> R=fail;
  222.      Ea=fail -> R=true;
  223.          R=not(Ea)
  224.     ).
  225.  
  226. $macpartev1(\+(A),R,Vi,Vi,Db,N) :- !,$macpartev(A,Ea,Vi,_,Db,N),
  227.     (Ea=true -> R=fail;
  228.      Ea=fail -> R=true;
  229.          R= \+(Ea)
  230.     ).
  231.  
  232. $macpartev1('!','!',V,V,_,_) :- !,
  233.     $writename('Expansion error: illegal cut(!)'),$nl.
  234.  
  235. $macpartev1(A,R,Vi,Vo,Db,N) :- 
  236.     $macapplyv(Vi,A,Ag),
  237.     $findall(::-(Ag,B),$member(::-(Ag,B),Db),Clauses),
  238.     (Clauses=[Clause] ->
  239.       (N=<0 -> $writename('Too deeply nested macros'),$nl,R=Ag,Vo=Vi;
  240.         N1 is N-1,$maccbv(Clause,::-(Nh,Nb),Vi,Vm),
  241.         $macunify(Ag,Nh,Vm,Vm2),$macpartev(Nb,R,Vm2,Vo,Db,N1)
  242.       );
  243.       R=Ag,Vo=Vi
  244.     ).
  245.  
  246.  
  247. $macbichk(X=Y,_).
  248. $macbichk(X is Y,V) :- $macground(Y,V).
  249. $macbichk(A,V) :- $macarith(A),$macground(A,V).
  250. $macbichk($arg(N,T,X),V) :- $macground(N,V),$macnonvar(T,V).
  251. $macbichk(arg(N,T,X),V) :- $macground(N,V),$macnonvar(T,V).
  252. $macbichk($functor(T,F,N),V) :- $macnonvar(N,V),$macnonvar(F,V).
  253. $macbichk($functor(T,F,N),V) :- $macnonvar(T,V).
  254. $macbichk($functor(T,F,N),V) :- integer(T,V).
  255. $macbichk(var(X),V) :- $macnonvar(X,V).
  256. $macbichk(nonvar(X),V) :- $macnonvar(X,V).
  257.  
  258. $macarith(_<_).
  259. $macarith(_>_).
  260. $macarith(_=<_).
  261. $macarith(_>=_).
  262. $macarith(_=:=_).
  263. $macarith(_=\=_).
  264.  
  265.  
  266. $macunify(Term1,Term2,Vi,Vo) :- 
  267.     $macderef(Term1,T1,Vi),$macderef(Term2,T2,Vi),
  268.     (var(T1) -> (T1==T2 -> Vo=Vi;Vo=[T1=T2|Vi]);
  269.      var(T2) -> Vo=[T2=T1|Vi];
  270.         $functor(T1,F,N),$functor(T2,F,N),$macunifyl(T1,T2,N,Vi,Vo)
  271.     ).
  272.  
  273. $macunifyl(T1,T2,0,V,V) :- !.
  274. $macunifyl(T1,T2,N,Vi,Vo) :- 
  275.     arg(N,T1,A1),arg(N,T2,A2),$macunify(A1,A2,Vi,Vm),
  276.     N1 is N-1,$macunifyl(T1,T2,N1,Vm,Vo).
  277.  
  278. $macderef(T1,T2,V) :- nonvar(T1) -> T1=T2;$macderef(T1,T2,V,V).
  279.  
  280. $macderef(T1,T1,[],_) :- !.
  281. $macderef(T1,T2,[T1p=T3|_],Vb) :- T1==T1p,!,$macderef(T3,T2,Vb).
  282. $macderef(T1,T2,[_|V],Vb) :- $macderef(T1,T2,V,Vb).
  283.  
  284.  
  285.  
  286. $macapplyv(V,Ti,To) :- $macderef(Ti,Tt,V),
  287.     (var(Tt) -> To=Tt;
  288.      $atomic(Tt) -> To=Tt;
  289.         $functor(Tt,F,N),$functor(To,F,N),$macapplyvl(V,Tt,To,N)
  290.     ).
  291. $macapplyvl(_,_,_,0) :- !.
  292. $macapplyvl(V,Ti,To,N) :- arg(N,Ti,A1),$macapplyv(V,A1,Ta1),arg(N,To,Ta1),
  293.     N1 is N-1,$macapplyvl(V,Ti,To,N1).
  294.  
  295. $macapplynv(V,Ti,To) :- $macderef(Ti,Tt,V),
  296.     (var(Tt) -> true;    /* new variables! */
  297.      $atomic(Tt) -> To=Tt;
  298.         $functor(Tt,F,N),$functor(To,F,N),$macapplynvl(V,Tt,To,N)
  299.     ).
  300. $macapplynvl(_,_,_,0) :- !.
  301. $macapplynvl(V,Ti,To,N) :- arg(N,Ti,A1),$macapplynv(V,A1,Ta1),arg(N,To,Ta1),
  302.     N1 is N-1,$macapplynvl(V,Ti,To,N1).
  303.  
  304.  
  305.  
  306.  
  307. $macnonvar(X,V) :- $macderef(X,Xd,V),nonvar(Xd).
  308.  
  309. $macground(X,V) :- $macderef(X,Xd,V),nonvar(Xd),$arity(Xd,N),$macgndl(Xd,N,V).
  310. $macgndl(X,N,V) :- N=:=0 -> true;
  311.              arg(N,X,A),$macground(A,V),N1 is N-1,$macgndl(X,N1,V).
  312.  
  313. $maccbv(Term,Newterm,Vi,Vo) :- var(Term),!,$macchkbnding(Term=Newterm,Vi,Vo).
  314. $maccbv(T,Nt,Vi,Vo) :- 
  315.     $functor(T,F,N),$functor(Nt,F,N),$maccbvl(N,T,Nt,Vi,Vo).
  316.  
  317. $maccbvl(N,T,Nt,Vi,Vo) :- 
  318.     N=:=0 -> Vi=Vo;
  319.         arg(N,T,T1),
  320.         $maccbv(T1,Nt1,Vi,Vm),
  321.         arg(N,Nt,Nt1),
  322.         N1 is N-1,$maccbvl(N1,T,Nt,Vm,Vo).
  323.  
  324. $macchkbnding(Nv=Ov,[],[Nv=Ov]) :- !.
  325. $macchkbnding(Nv=Ov,V,V) :- V=[Nv1=Ov|_],Nv == Nv1,!.
  326. $macchkbnding(P,[X|Vi],[X|Vo]) :- $macchkbnding(P,Vi,Vo).
  327.  
  328.  
  329. $macgetfreev(Q,V) :- $macgetfreev(Q,V,[]).
  330. $macgetfreev(Q,Vo,Vi) :- 
  331.     var(Q) -> $macaddee(Q,Vi,Vo);
  332.         $functor(Q,F,N),$macgetfreel(Q,Vo,Vi,N).
  333. $macgetfreel(Q,Vo,Vi,N) :- N=:=0 -> Vo=Vi;
  334.     arg(N,Q,A),$macgetfreev(A,Vm,Vi),N1 is N-1,$macgetfreel(Q,Vo,Vm,N1).
  335.  
  336. $macaddee(Q,[],[Q]).
  337. $macaddee(Q,V,V) :- V=[Qp|_],Qp==Q,!.
  338. $macaddee(Q,[X|Vi],[X|Vo]) :- $macaddee(Q,Vi,Vo).
  339.  
  340. $macgetbnds(Fv,V,B) :- $macgetbnds(Fv,V,B,true).
  341. $macgetbnds([],_,B,B).
  342. $macgetbnds([X|Fv],V,Bo,Bi) :- 
  343.     $macapplyv(V,X,T),
  344.     (var(T) -> $macgetbnds(Fv,V,Bo,Bi);
  345.         (Bi=true -> Bm=(X=T);Bm=(X=T,Bi)),
  346.         $macgetbnds(Fv,V,Bo,Bm)
  347.     ).
  348.  
  349.  
  350. $macgetfvb(V,[],[]).
  351. $macgetfvb(V,[X|Fvs],[X=T|Fbs]) :- $macvderef(X,T,V),$macgetfvb(V,Fvs,Fbs).
  352.  
  353. $macvderef(T1,T2,V) :- $macvderef(T1,T2,V,V).
  354. $macvderef(T1,T1,[],_) :- !.
  355. $macvderef(T1,T2,[T1p=T3|V],Vb) :- 
  356.     T1==T1p,!,(var(T3) -> $macvderef(T3,T2,Vb);T2=T1).
  357. $macvderef(T1,T2,[_|V],Vb) :- $macvderef(T1,T2,V,Vb).
  358.  
  359. $macapplyfv(V,Vf,Ti,To) :- 
  360.     var(Ti) -> $macvderef(Ti,T1,V),$macunderef(T1,To,Vf);
  361.         $functor(Ti,F,N),$functor(To,F,N),$macapplyfvl(V,Vf,Ti,To,N).
  362. $macapplyfvl(V,Vf,Ti,To,N) :- N=:=0 -> true;
  363.     arg(N,Ti,A1),$macapplyfv(V,Vf,A1,Ta1),arg(N,To,Ta1),
  364.     N1 is N-1,$macapplyfvl(V,Vf,Ti,To,N1).
  365.  
  366. $macunderef(T1,T1,[]) :- !.
  367. $macunderef(T1,T2,[T2=T3|V]) :- T1==T3,!.
  368. $macunderef(T1,T2,[_|V]) :- $macunderef(T1,T2,V).
  369.  
  370.  
  371.  
  372. $macprintprds([]).
  373. $macprintprds([pred(_,_,_,_,Clauses)|R]) :-
  374.     $macprintcls(Clauses),nl,$macprintprds(R).
  375.  
  376. $macprintcls([]).
  377. $macprintcls([fact(Fact,_)|R]) :-
  378.     $portray_term(Fact), $write('.'), $nl, $macprintcls(R).
  379. $macprintcls([rule(Head,Body,_,_)|R]) :-
  380.     $portray_clause((Head :- Body)),
  381.     $macprintcls(R).
  382.  
  383.