home *** CD-ROM | disk | FTP | other *** search
/ rtsi.com / 2014.01.www.rtsi.com.tar / www.rtsi.com / OS9 / OSK / EFFO / pd3.lzh / SBPROLOG2.2 / MODLIB / MODLIB_SRC / $dbcmpl.P < prev    next >
Text File  |  1991-08-10  |  17KB  |  525 lines
  1. /************************************************************************
  2. *                                    *
  3. *    The SB-Prolog System                        *
  4. *    Copyright SUNY at Stony Brook, 1986                *
  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 Prolog predicates that compiles a clause into a 
  27. buffer. It treats all rules as though they had a single literal on the
  28. right-hand-side. Thus it compiles a clause with more than one literal
  29. on the right-hand-side as a call to the predicate ,/2 */
  30.  
  31. $dbcmpl_export([$db_cmpl/5,$db_cmpl/6,$db_putbuffop/4,$db_putbuffbyte/4,
  32.     $db_putbuffnum/4]).
  33.  
  34. /* $dbcmpl_use($buff,
  35.     [$alloc_perm/2,$alloc_heap/2,$trimbuff/3,$buff_code/4,$symtype/2,
  36.         $substring/6,$subnumber/6,$subdelim/6,$conlength/2,
  37.         $pred_undefined/1, $hashval/3]).
  38.    $dbcmpl_use($bmeta,[$atom/1,$atomic/1,$integer/1,$number/1,$structure/1,
  39.     $functor0/2,$bldstr/3,$arg/3,$arity/2,$real/1,$floor/2]).
  40.    $db_use($bio,[$writename/1,$writeqname/1,$put/1,$nl/0,$tab/1,
  41.     $tell/1,$tell/2,$telling/1,$told/0,$get/1,$get0/1,$see/1,$seeing/1,
  42.     $seen/0]).
  43. */
  44.  
  45. $db_putbuffop(Opn,Buff,Li,Lo) :- 
  46.     $buff_code(Buff,Li,3 /*pb*/ ,Opn), Lo is Li+1.
  47.  
  48. $db_putbuffope(Opn,Buff,Li,Lo) :- 
  49.     $buff_code(Buff,Li,3 /*pb*/ ,Opn), Li1 is Li+1,
  50.     $buff_code(Buff,Li1,3 /*pb*/ ,0), Lo is Li1+1.
  51.  
  52. $db_putbuffbyte(Num,Buff,Li,Lo) :- 
  53.     $buff_code(Buff,Li,3 /*pb*/ ,Num), Lo is Li+1.
  54.  
  55. $db_putbuffnum(Num,Buff,Li,Lo) :- 
  56.     $buff_code(Buff,Li,2 /*pn*/ ,Num), Lo is Li+4.
  57.  
  58. $db_putbuffloat(Num,Buff,Li,Lo) :- 
  59.     $buff_code(Buff,Li,27 /*pf*/ ,Num), Lo is Li+4.
  60.  
  61. $db_putbuffptr(Num,Buff,Li,Lo) :- 
  62.     $buff_code(Buff,Li,1 /*pppsc*/ ,Num), Lo is Li+4.
  63.  
  64. $db_putbuffpsc(Num,Buff,Li,Lo) :- 
  65.     $buff_code(Buff,Li,0 /*ppsc*/ ,Num), Lo is Li+4.
  66.  
  67.  
  68. /* $db_cmpl(Clause,Clref,Index,Where,Supbuff): where Clause is a fact or
  69. rule. Clref is a variable through which is returned the Clref, and 
  70. Index is the argument to index on (0 if none). Where is 0 if the 
  71. buffer is to be allocated from the permanent area, and 2 if from a
  72. superbuff, which is in Supbuff. */
  73.  
  74. $db_cmpl(Clause,Buff,Index,Where,Supbuff) :- 
  75.     $db_cmpl(Clause,Buff,Index,Where,Supbuff,1).
  76.  
  77. $db_cmpl(Clause,Buff,Index,Where,Supbuff,Flatten) :- 
  78.     $alloc_buff(5000,Buff,Where,Supbuff,_),    /* must return Buff */
  79.     ((Clause=(_:-_) -> Clause=(Head:-Body); Clause=Head, Body=true),
  80.      $arity(Head,Arity),
  81.      Tempreg is Arity+1, 
  82.      $buff_code(Buff,0,14 /*ptv*/ ,Buff), /*set back pointer*/
  83.      $db_gentop(Head,Arity,1,Tempreg,Freereg,Buff,10,Lhd,uniq),
  84.      (Flatten =:= 1 ->
  85.          ($db_flatten(Body,FBody,[],Unifs),
  86.          $db_flcode(Unifs,Freereg,R0,Buff,Lhd,Lm0,uniq)
  87.         ) ;
  88.         (Body = FBody, R0 = Freereg, Lm0 = Lhd)
  89.      ),
  90.      $arity(FBody,Barity),
  91.      $db_genbod(FBody,Barity,1,[],Mvl,R0,Maxreg,Buff,Lm0,Lm1,uniq),
  92.      (Index > 0 -> $db_putbuffchain(Buff, Lm1, Length);
  93.                 Length = Lm1),
  94.      (Length > 5000,!,$db_mfail('Asserted clause too long ',Length);
  95.       Length =< 5000,
  96.        (Maxreg > 255,!,
  97.          $db_mfail('Assert: too many registers required ',Maxreg);
  98.         Maxreg =< 255,
  99.          $trimbuff(Length,Buff,Where,Supbuff),fail
  100.        )
  101.      )
  102.     ;
  103.      true
  104.     ).
  105.  
  106.  
  107. $db_mfail(Msg,Val) :- 
  108.     $telling(F),$tell(user),
  109.     $writename(Msg),$writename(Val),$nl,
  110.     $tell(F),fail.
  111.  
  112. $db_putbuffchain(Buff, Lin, Lout) :-
  113.         /* put code at the end for chaining clauses in the same bucket  */
  114.     $db_putbuffop(249 /* noop */, Buff, Lin, L1),
  115.         $db_putbuffbyte(2, Buff, L1, L2),
  116.         $db_putbuffnum(0, Buff, L2, L3),
  117.         $db_putbuffope(240 /* jump */, Buff, L3, L4),
  118.         $buff_code(Buff, 10, 4, EPADDR), /* get start address of the code*/
  119.         $db_putbuffnum(EPADDR, Buff, L4, Lout).
  120.  
  121. $db_gentop(Fact,Arity,Argno,Ri,Ro,Buff,Li,Lo,U) :- 
  122.     Argno > Arity,
  123.      Ri = Ro, Li=Lo
  124.     ;
  125.     Argno =< Arity, $arg(Argno,Fact,T),
  126.      $db_gentopinst(T,Argno,Ri,Rm,Buff,Li,Lm,U),
  127.      Argno1 is Argno + 1,
  128.      $db_gentop(Fact,Arity,Argno1,Rm,Ro,Buff,Lm,Lo,U).
  129.  
  130. $db_gentopinst(T,Argno,Ri,Ro,Buff,Li,Lo,U) :-
  131.     var(T), T='$var'(Argno,U), Ri = Ro, Li = Lo 
  132.     ;
  133.     nonvar(T),
  134.      ($atom(T) ->
  135.        ((T = [] ->
  136.          ($db_putbuffop(5,Buff,Li,Li1),    /* getnil(Argno) */
  137.           $db_putbuffbyte(Argno,Buff,Li1,Lo)
  138.            ) ;
  139.          ($db_putbuffop(4,Buff,Li,Li1),    /* getcon(T,Argno) */
  140.              $db_putbuffbyte(Argno,Buff,Li1,Li2),
  141.              $db_putbuffptr(T,Buff,Li2,Lo)
  142.            )
  143.         ),
  144.         Ri = Ro
  145.        ) ;
  146.        ($integer(T) ->             /* getnumcon(T,Argno) */
  147.         ($db_putbuffop(14,Buff,Li,Li1),
  148.          $db_putbuffbyte(Argno,Buff,Li1,Li2),
  149.          $db_putbuffnum(T,Buff,Li2,Lo),
  150.          Ri = Ro
  151.         ) ;
  152.         ($real(T) ->             /* getfloatcon(T,Argno) */
  153.             ($db_putbuffop(32,Buff,Li,Li1),
  154.              $db_putbuffbyte(Argno,Buff,Li1,Li2),
  155.              $db_putbuffloat(T,Buff,Li2,Lo),
  156.              Ri = Ro
  157.             ) ;
  158.             ((T='$var'(Rt,Un), nonvar(Un), Un=U ) ->
  159.                      /* gettval(Rt,Argno) */
  160.                 ($db_putbuffope(3,Buff,Li,Li1),
  161.                    $db_putbuffbyte(Rt,Buff,Li1,Li2),
  162.                    $db_putbuffbyte(Argno,Buff,Li2,Lo),
  163.                    Ri = Ro
  164.                 ) ;
  165.                 $db_genterms([Argno,T],Ri,Ro,Buff,Li,Lo,U)
  166.             )
  167.             )
  168.         )
  169.      ).
  170.  
  171. $db_genterms([],R,R,_,L,L,_).
  172. $db_genterms([R,T|Ts],Ri,Ro,Buff,Li,Lo,U) :-
  173.     $db_genstruc(T,R,Buff,Ri,Rm,Li,Lm2,Substrs,U),
  174.     $db_genterms(Substrs,Rm,Rm2,Buff,Lm2,Lm3,U),
  175.     $db_genterms(Ts,Rm2,Ro,Buff,Lm3,Lo,U).
  176.  
  177. $db_genstruc((A1,A2),R,Buff,Ri,Ro,Li,Lo,[],U) :-
  178.     var(A1),var(A2),not(A1==A2),!,A1 = '$var'(Ri,U),
  179.     Rm1 is Ri+1, A2 = '$var'(Rm1,U), Ro is Rm1+1,
  180.     /* generate a getcomma_tvar_tvar */
  181.     $db_putbuffop(74,Buff,Li,Lm1),
  182.     $db_putbuffbyte(R,Buff,Lm1,Lm2),
  183.     $db_putbuffbyte(Ri,Buff,Lm2,Lm3),
  184.     $db_putbuffbyte(Rm1,Buff,Lm3,Lo).
  185.  
  186. $db_genstruc([A1|A2],R,Buff,Ri,Ro,Li,Lo,[],U) :-
  187.     var(A1),var(A2),not(A1==A2),!,A1 = '$var'(Ri,U),
  188.     Rm1 is Ri+1, A2 = '$var'(Rm1,U), Ro is Rm1+1,
  189.     /* generate a getlist_tvar_tvar */
  190.     $db_putbuffop(72,Buff,Li,Lm1),
  191.     $db_putbuffbyte(R,Buff,Lm1,Lm2),
  192.     $db_putbuffbyte(Ri,Buff,Lm2,Lm3),
  193.     $db_putbuffbyte(Rm1,Buff,Lm3,Lo).
  194.  
  195. $db_genstruc(T,R,Buff,Ri,Rm,Li,Lo,Substrs,U) :-
  196.     $db_genget(T,R,Buff,Li,Lm1),$arity(T,Arity),
  197.     $db_dosubs(T,0,Arity,Ri,Rm,Buff,Lm1,Lo,Substrs,[],U).
  198.  
  199.  
  200. $db_genget([_|_],R,Buff,Li,Lo) :- !,
  201.     /* getlist(R) */
  202.     $db_putbuffop(7,Buff,Li,Li1),
  203.     $db_putbuffbyte(R,Buff,Li1,Lo).
  204. $db_genget((_,_),R,Buff,Li,Lo) :- /* not(T=[_|_]) */ !,
  205.     /* getcomma(R) */
  206.     $db_putbuffop(73,Buff,Li,Li1),
  207.     $db_putbuffbyte(R,Buff,Li1,Lo).
  208. $db_genget(T,R,Buff,Li,Lo) :- /* not(T=(_,_)),not(T=[_|_]) */
  209.     /* functor(T,F,Arity), getstr((F,Arity),R) */
  210.     $db_putbuffop(6,Buff,Li,Li1),
  211.     $db_putbuffbyte(R,Buff,Li1,Li2),
  212.     $db_putbuffpsc(T,Buff,Li2,Lo).
  213.  
  214. $db_dosubs(T,I,Arity,Ri,Ro,Buff,Li,Lo,Si,So,U) :-
  215.     I < Arity, I1 is I+1, $arg(I1,T,Sub),
  216.      $db_geninst(Sub,Ri,Rm,Si,Sm,Buff,Li,Lm,U),
  217.      $db_dosubs(T,I1,Arity,Rm,Ro,Buff,Lm,Lo,Sm,So,U)
  218.     ;
  219.     I >= Arity,        /* just to avoid having to lay down a CP */
  220.      I = Arity,Ri = Ro,Li = Lo,Si = So.
  221.  
  222. $db_geninst(Sub,Ri,Ro,Si,So,Buff,Li,Lo,U) :-
  223.     var(Sub), Si = So,
  224.       Ro is Ri+1, Sub='$var'(Ri,U),     /* unitvar(Ri) */
  225.       $db_putbuffop(10,Buff,Li,Li1),
  226.       $db_putbuffbyte(Ri,Buff,Li1,Lo)
  227.      ;
  228.       nonvar(Sub),
  229.          ($atom(Sub) ->
  230.             ((Sub=[] -> 
  231.                  $db_putbuffope(13,Buff,Li,Lo) ;    /* uninil */
  232.                  ($db_putbuffope(12,Buff,Li,Li1),  /* unicon(Sub) */
  233.               $db_putbuffptr(Sub,Buff,Li1,Lo))
  234.          ),
  235.           Ri = Ro, Si = So) ;
  236.         ($integer(Sub) ->               /* uninumcon(Sub) */
  237.               ($db_putbuffope(30,Buff,Li,Li1),
  238.                $db_putbuffnum(Sub,Buff,Li1,Lo),
  239.                Ri = Ro, Si = So) ;
  240.                ($real(Sub) ->               /* unifloatcon(Sub) */
  241.                       ($db_putbuffope(34,Buff,Li,Li1),
  242.                         $db_putbuffloat(Sub,Buff,Li1,Lo),
  243.                      Ri = Ro, Si = So) ;
  244.                      ((Sub='$var'(R,Un),nonvar(Un),Un=U) ->
  245.                             /* unitval(R) */
  246.                     ($db_putbuffop(11,Buff,Li,Li1),
  247.                       $db_putbuffbyte(R,Buff,Li1,Lo),
  248.                       Ri = Ro, Si = So) ;
  249.                     (Ro is Ri+1,        /* unitvar(Ri) */
  250.                       Si = [Ri,Sub|So],
  251.                       $db_putbuffop(10,Buff,Li,Li1),
  252.                       $db_putbuffbyte(Ri,Buff,Li1,Lo))
  253.                        )
  254.             )
  255.         )
  256.          ).
  257.  
  258. $db_genbod(true,0,1,Mvlst,Mvlst,R,R,Buff,Li,Lo,U) :- !,
  259.     $db_putbuffope(235 /*proceed*/ ,Buff,Li,Lo).
  260. $db_genbod(Body,Arity,Argno,Mvlst,Mvlsto,Ri,Ro,Buff,Locin,Locout,U) :-
  261.     $db_genbo1(Body,Arity,Argno,Mvlst,Mvlsto,Ri,Ro,Buff,Locin,Locout,U).
  262.  
  263. $db_genbo1(Body,Arity,Argno,Mvlst,Mvlsto,Ri,Ro,Buff,Locin,Locout,U) :-
  264.     Argno > Arity ->
  265.      Mvlst=Mvlsto,
  266.      $db_genmvs(Mvlst,Ri,Ro,Buff,Locin,Lm1),
  267.      functor(Body,Bodyn,Arity), /* wnl(execute(Bodyn,Arity)), */
  268.      $db_putbuffope(236,Buff,Lm1,Lm2),
  269.      $db_putbuffpsc(Body,Buff,Lm2,Locout)
  270.     ;
  271.      $arg(Argno,Body,T),
  272.      $db_genaput(T,Argno,Mvlst,Mvlstm,Ri,Rm,Buff,Locin,Locm,U),
  273.      Argno1 is Argno+1,
  274.      $db_genbo1(Body,Arity,Argno1,Mvlstm,Mvlsto,Rm,Ro,Buff,Locm,Locout,U).
  275.  
  276. $db_genaput(T,Argno,Mvlst,Mvlsto,Ri,Ro,Buff,Locin,Locout,U) :-
  277.     var(T) ->
  278.      Ro is Ri+1,Locout=Locin,Mvlsto=[puttvar(Tempvar),Argno|Mvlst],
  279.      T='$var'(Tempvar,U)
  280.     ;
  281.      (T='$var'(Rt,U) ->
  282.        (var(Rt) -> Mvlsto=[puttvar(Rt),Argno|Mvlst];
  283.                Mvlsto=[movreg(Rt),Argno|Mvlst]),
  284.        Ro=Ri,Locout=Locin
  285.       ;
  286.        ($integer(T) ->
  287.          Mvlsto=[putnumcon(T),Argno|Mvlst],Ro=Ri,Locout=Locin
  288.         ;
  289.          ($real(T) ->
  290.            (Mvlsto=[putfloatcon(T),Argno|Mvlst],Ro=Ri,Locout=Locin)
  291.           ;
  292.           ($atom(T) ->
  293.         (T=[] -> Mvlsto=[putnil,Argno|Mvlst];
  294.              Mvlsto=[putcon(T),Argno|Mvlst]),
  295.         Ro=Ri,Locout=Locin
  296.           ;
  297.         Mvlsto=[movreg(Ri),Argno|Mvlst],Rm is Ri+1,
  298.             $db_putterm(Ri,T,Rm,Ro,Buff,Locin,Locout,U)
  299.          )
  300.        )
  301.      )
  302.     ).
  303.  
  304. $db_putterm(R,T,Ri,Ro,Buff,Li,Lo,U) :-
  305.     $arity(T,Arity),
  306.     $db_putsubstr(T,0,Arity,Ri,Rm,Buff,Li,Lm1,[],Subterms,U),
  307.     $db_genputstr(T,R,Buff,Lm1,Lm2),
  308.     $db_putsubs(Subterms,Rm,Ro,Buff,Lm2,Lo).
  309.  
  310. $db_genputstr([_|_],R,Buff,Li,Lo) :- !,
  311.     /* wnl(putlist(R)), */
  312.     $db_putbuffop(23,Buff,Li,Li1),
  313.     $db_putbuffbyte(R,Buff,Li1,Lo).
  314. /* $db_genputstr((_,_),R,Buff,Li,Lo) :- * not(T=[_|_]) * !,
  315.      * getcomma(R) *
  316.     $db_putbuffop(73,Buff,Li,Li1),
  317.     $db_putbuffbyte(R,Buff,Li1,Lo). */
  318. $db_genputstr(T,R,Buff,Li,Lo) :- /* not(T=(_,_)),not(T=[_|_]) */
  319.     /* functor(T,F,Arity), wnl(putstr((F,Arity),R)), */
  320.     $db_putbuffop(22,Buff,Li,Li1),
  321.     $db_putbuffbyte(R,Buff,Li1,Li2),
  322.     $db_putbuffpsc(T,Buff,Li2,Lo).
  323.  
  324. $db_putsubstr(T,I,Arity,Ri,Ro,Buff,Li,Lo,Si,So,U) :-
  325.     I < Arity -> I1 is I+1, $arg(I1,T,Sub),
  326.      $db_bldsubs(Sub,Ri,Rm,Si,Sm,Buff,Li,Lm,U),
  327.      $db_putsubstr(T,I1,Arity,Rm,Ro,Buff,Lm,Lo,Sm,So,U)
  328.     ;
  329.      I = Arity,Ri = Ro,Li = Lo,Si = So.
  330.  
  331. $db_bldsubs(Sub,Ri,Ro,Si,So,Buff,Li,Lo,U) :-
  332.     var(Sub) -> So = [bldtvar(Ri)|Si],
  333.       Ro is Ri+1, Li = Lo, Sub='$var'(Ri,U)     /* bldtvar(Ri) */
  334.      ;
  335.       ($atom(Sub) ->
  336.          (Sub=[] -> So = [bldnil|Si];    /* bldnil */
  337.             So = [bldcon(Sub)|Si]), /* bldcon(Sub) */
  338.          Ri = Ro, Li = Lo
  339.         ;
  340.          ($integer(Sub) ->               /* bldnumcon(Sub) */
  341.         So = [bldnumcon(Sub)|Si], Ri = Ro, Li = Lo
  342.           ;
  343.             ($real(Sub) ->               /* bldfloatcon(Sub) */
  344.            (So = [bldfloatcon(Sub)|Si], Ri = Ro, Li = Lo) ;
  345.            ((Sub='$var'(R,Un),nonvar(Un),Un=U) ->
  346.               So = [bldtval(R)|Si],    /* bldtval(R) */
  347.               Ri = Ro,Li = Lo
  348.              ;
  349.               Rm is Ri+1,        /* bldtvar(Ri) */
  350.               So = [bldtval(Ri)|Si], 
  351.               $db_putterm(Ri,Sub,Rm,Ro,Buff,Li,Lo,U)
  352.           ) 
  353.         )
  354.          )
  355.       ).
  356.  
  357. $db_putsubs([],R,R,_,L,L).
  358. $db_putsubs([Bld|Rest],Ri,Ro,Buff,Li,Lo) :-
  359.     $db_putsubs(Rest,Ri,Ro,Buff,Li,Lm),
  360.     $db_bldinst(Bld,Buff,Lm,Lo).
  361.  
  362. $db_bldinst(bldtvar(R),Buff,Li,Lo) :-
  363.     /* wnl(bldtvar(R)), */
  364.     $db_putbuffop(26,Buff,Li,Li1),
  365.     $db_putbuffbyte(R,Buff,Li1,Lo).
  366. $db_bldinst(bldnil,Buff,Li,Lo) :-
  367.     /* wnl(bldnil), */
  368.     $db_putbuffope(29,Buff,Li,Lo).
  369. $db_bldinst(bldcon(Sub),Buff,Li,Lo) :-
  370.     /* wnl(bldcon(Sub)), */
  371.     $db_putbuffope(28,Buff,Li,Li1),
  372.     $db_putbuffptr(Sub,Buff,Li1,Lo).
  373. $db_bldinst(bldnumcon(Sub),Buff,Li,Lo) :-
  374.     /* wnl(bldnumcon(Sub)), */
  375.     $db_putbuffope(31,Buff,Li,Li1),
  376.     $db_putbuffnum(Sub,Buff,Li1,Lo).
  377. $db_bldinst(bldfloatcon(Sub),Buff,Li,Lo) :-
  378.     /* wnl(bldfloatcon(Sub)), */
  379.     $db_putbuffope(35,Buff,Li,Li1),
  380.     $db_putbuffloat(Sub,Buff,Li1,Lo).
  381. $db_bldinst(bldtval(R),Buff,Li,Lo) :-
  382.     /* wnl(bldtval(R)), */
  383.     $db_putbuffop(27,Buff,Li,Li1),
  384.     $db_putbuffbyte(R,Buff,Li1,Lo).
  385.  
  386.  
  387. /* this is a simple routine to generate  a series  of instructions to
  388. load a series of  registers with  constants or  from other registers.
  389. It is  given a  list of  Source,Target pairs.   Target  is always a
  390. register  number.  Source may be a putcon(con), putnumcon(num), putfloatcon(num),
  391. puttvar(reg),  puttvar(Var),  or  movreg(reg).    The  registers  can
  392. overlap in any way.  $db_genmvs tries to generate  a reasonably efficient
  393. series  of  instructions  to  load  the indicated  registers with the
  394. indicated values.  */ 
  395.  
  396. $db_genmvs([],R,R,B,L,L).
  397. $db_genmvs([I,T|Rest],Ri,Ro,Buff,Li,Lo) :- $db_genmvs(I,T,Ri,Ro,Buff,Li,Lo,Rest).
  398.  
  399. $db_genmvs(puttvar(R),T,Ri,Ro,Buff,Li,Lo,Rest) :-
  400.     $db_genmvs(Rest,Ri,Ro,Buff,Li,Lm),
  401.     (nonvar(R) -> 
  402.         /* wnl(movreg(R,T)), */
  403.         $db_putbuffope(209,Buff,Lm,Lm1),
  404.         $db_putbuffbyte(R,Buff,Lm1,Lm2),
  405.         $db_putbuffbyte(T,Buff,Lm2,Lo)
  406.       ;
  407.         R=T, /* wnl(puttvar(R,R)), */
  408.         $db_putbuffope(18,Buff,Lm,Lm1),
  409.         $db_putbuffbyte(R,Buff,Lm1,Lm2),
  410.         $db_putbuffbyte(R,Buff,Lm2,Lo)
  411.     ).
  412.  
  413. $db_genmvs(putcon(C),T,Ri,Ro,Buff,Li,Lo,Rest) :- !,
  414.     $db_genmvs(Rest,Ri,Ro,Buff,Li,Lm),
  415.     /* wnl(putcon(T,C)), */
  416.     $db_putbuffop(20,Buff,Lm,Lm1),
  417.     $db_putbuffbyte(T,Buff,Lm1,Lm2),
  418.     $db_putbuffptr(C,Buff,Lm2,Lo).
  419.  
  420. $db_genmvs(putnil,T,Ri,Ro,Buff,Li,Lo,Rest) :- !,
  421.     $db_genmvs(Rest,Ri,Ro,Buff,Li,Lm),
  422.     /* wnl(putnil(T)), */
  423.     $db_putbuffop(21,Buff,Lm,Lm1),
  424.     $db_putbuffbyte(T,Buff,Lm1,Lo).
  425.  
  426. $db_genmvs(putnumcon(I),T,Ri,Ro,Buff,Li,Lo,Rest) :- !,
  427.     $db_genmvs(Rest,Ri,Ro,Buff,Li,Lm),
  428.     /* wnl(putnumcon(T,I)), */
  429.     $db_putbuffop(15,Buff,Lm,Lm1),
  430.     $db_putbuffbyte(T,Buff,Lm1,Lm2),
  431.     $db_putbuffnum(I,Buff,Lm2,Lo).
  432.  
  433. $db_genmvs(putfloatcon(I),T,Ri,Ro,Buff,Li,Lo,Rest) :- !,
  434.     $db_genmvs(Rest,Ri,Ro,Buff,Li,Lm),
  435.     /* wnl(putfloatcon(T,I)), */
  436.     $db_putbuffop(33,Buff,Lm,Lm1),
  437.     $db_putbuffbyte(T,Buff,Lm1,Lm2),
  438.     $db_putbufffloat(I,Buff,Lm2,Lo).
  439.  
  440. $db_genmvs(movreg(R),R,Ri,Ro,Buff,Li,Lo,Rest) :- !,
  441.     $db_genmvs(Rest,Ri,Ro,Buff,Li,Lo).
  442.  
  443. $db_genmvs(movreg(S),T,Ri,Ro,Buff,Li,Lo,Rest) :- not($dbcmpl_frstmem(T,Rest)),!,
  444.     /* wnl(movreg(S,T)), */
  445.     $db_putbuffope(209,Buff,Li,Lm1),
  446.     $db_putbuffbyte(S,Buff,Lm1,Lm2),
  447.     $db_putbuffbyte(T,Buff,Lm2,Lm),
  448.     $db_genmvs(Rest,Ri,Ro,Buff,Lm,Lo).
  449.  
  450. $db_genmvs(movreg(S),T,Ri,Ro,Buff,Li,Lo,Rest) :- not($dbcmpl_scndmem(S,Rest)),!,
  451.     $db_genmvs(Rest,Ri,Ro,Buff,Li,Lm),
  452.     /* wnl(movreg(S,T)), */
  453.     $db_putbuffope(209,Buff,Lm,Lm1),
  454.     $db_putbuffbyte(S,Buff,Lm1,Lm2),
  455.     $db_putbuffbyte(T,Buff,Lm2,Lo).
  456.  
  457. $db_genmvs(movreg(S),T,Ri,Ro,Buff,Li,Lo,Rest) :- 
  458.     /* wnl(movreg(S,Ri)), */
  459.     $db_putbuffope(209,Buff,Li,Lm1),
  460.     $db_putbuffbyte(S,Buff,Lm1,Lm2),
  461.     $db_putbuffbyte(Ri,Buff,Lm2,Lm3),
  462.     Rm is Ri+1,
  463.     $db_genmvs(Rest,Rm,Ro,Buff,Lm3,Lm4),
  464.     /* wnl(movreg(Ri,T)), */
  465.     $db_putbuffope(209,Buff,Lm4,Lm5),
  466.     $db_putbuffbyte(Ri,Buff,Lm5,Lm6),
  467.     $db_putbuffbyte(T,Buff,Lm6,Lo).
  468.  
  469.  
  470. /* wnl(X) :- write(X),nl. */
  471.  
  472.  
  473. $dbcmpl_frstmem(T,[movreg(T),_|_]).
  474. $dbcmpl_frstmem(T,[_|Rest]) :- $dbcmpl_frstmem(T,Rest).
  475.  
  476.  
  477. $dbcmpl_scndmem(S,[_,S|_]).
  478. $dbcmpl_scndmem(S,[_|Rest]) :- $dbcmpl_scndmem(S,Rest).
  479.  
  480. /*  This is a kludge to fix up a problem with the depth-first
  481.     traversal of arguments interacting in a bad way with the
  482.     flattening of terms.  The problem is that when translating
  483.     arguments in the body, the depth first traversal doesn't take
  484.     into account the fact that subterms may move forward due to
  485.     flattening, thereby changing "first" and "subsequent"
  486.     occurrences of variables.  To make things work, though much
  487.     less efficiently than before, I'm just going through an
  488.     explicit flattening stage beforehand.  I don't doubt there
  489.     are more elegant solutions, I'm just a user who wants to
  490.     use assert to do other things.                */
  491.  
  492. $db_flatten(Term,NewTerm,Si,So) :-
  493.     $structure(Term) ->
  494.         (functor(Term,F,N),
  495.          functor(NewTerm,F,N),
  496.          $db_flatten1(Term,0,N,NewTerm,Si,So)
  497.         );
  498.         (NewTerm = Term, Si = So).
  499.  
  500. $db_flatten1(Term,N,Arity,NewTerm,Si,So) :-
  501.     (N =:= Arity) ->
  502.         (Si = So) ;
  503.         (ArgNo is N + 1,
  504.          arg(ArgNo,Term,OldArg),
  505.          arg(ArgNo,NewTerm,NewArg),
  506.          ($structure(OldArg) ->    /* nested structure, needs flattening */
  507.              (Sm0 = [NewArg,NewArg0|Si],
  508.              $db_flatten(OldArg,NewArg0,Sm0,Sm1)
  509.             ) ;
  510.             (OldArg = NewArg, Sm1 = Si)
  511.          ),
  512.          N1 is N + 1,
  513.          $db_flatten1(Term,N1,Arity,NewTerm,Sm1,So)
  514.         ).
  515.  
  516. $db_flcode([],R,R,_Buff,Loc,Loc,_).
  517. $db_flcode([Temp,Str|Rest],Ri,Ro,Buff,Li,Lo,U) :-
  518.     Temp = '$var'(R,U),
  519.     ((var(R), R = Ri, Rm0 is Ri+1) ;
  520.      (nonvar(R), Rm0 = Ri)
  521.     ),
  522.     $db_putterm(R,Str,Rm0,Rm1,Buff,Li,Lm,U),
  523.     $db_flcode(Rest,Rm1,Ro,Buff,Lm,Lo,U).
  524.  
  525.