unify.scm 3.58 KB
Newer Older
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1 2
(define-module (logic guile-log vm unify)
  #:use-module (logic guile-log vm utils)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
3 4 5 6 7 8 9 10
  #:use-module ((logic guile-log iso-prolog)
		#:renamer
		(lambda (s)
		  (cond
		   ((eq? s 'cc) 'pl-cc)
		   ((eq? s 'reset) 'pl-reset)
		   (else s))))
  
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
11 12 13 14 15 16 17 18 19
  #:export (ggset unify unify-2 unify-constant-2
                  unify-instruction pre-unify post-unify-tail
                  post-unify
))


(compile-prolog-string
"

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
20
  ggset(V,I,I,L,LL) :-     
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
21 22 23
     scmcall('gp-set',[V,sp(-1),s],I,I1,L,L1),
     reset(I,L1,LL).

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
24 25 26
  'pre-unify'(V,I,L,LL) :-
     vset('call?',c(0),I,L,L1),
     gset(V,top(delayers),I,L,L1).
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46

  'post-unify'(V,Nsloc,I,L,LL) :-
     gref(V,I,L,L1),
     II is I + 1,
     gset(V,c(#f),II,L2,L3),
     gref(delayers,II,L3,L4),
     generate(eq(I,II),L4,L5),
     generate(je(E),L5,L6),
     generate('delay-call'(Nsloc),L6,LL),
     label(E,LL).


  'post-unify-tail'(V,Nsloc,I,L,LL) :-
     gref(V,I,L,L1),
     II is I + 1,
     gset(V,c(#f),II,L2,L3),
     gref(delayers,II,L3,L4),
     generate(eq(I,II),L4,L5),
     generate(je(E),L5,L6),
     generate('delay-call'(Nsloc),L6,L7),
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
47 48
     label(E,LL),
     cc(L7,LL).
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
49 50 51


   unify(Code,V,I,II,L,LL) :-
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
52 53 54
      M is (Code /\\ 3),
      A is (Code /\\ 4)  >> 2,
      K is (Code /\\ 24) >> 3,      
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
55 56
      (
        M==2 ->
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
57
          pltest('gp-m-unify',[V,sp(I-1),s],I,_,L,L1);
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
58
        (M==3 ; K==3) ->
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
59 60
          pltest_s('gp-unify-raw',[V,sp(I-1),s],I,L,L1);
        pltest_s('gp-unify',[V,sp(I-1),s],I,L,L1)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
61 62 63 64 65 66 67
      ),
      II is I - 1,
      reset(II,L1,LL).



   'unify-2'(Code,V1,V2,I,L,LL) :-
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
68
      M     is Code /\\ 3,
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
69
      Code2 is Code >> 2,
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
70 71
      A1    is Code2 /\\ 1,
      K1    is (Code2 /\\ 6) >> 1,
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
72
      Code3 is Code2 >> 24,
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
73 74
      A2    is Code3 /\\ 1,
      K2    is (Code3 /\\ 6) >> 1,
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104
      
      (
          K1 == 2 ->
              (
                 (
                    K2 == 2 ->
                       (
                         scmcall('gp-var!',[s],I,I1,L,L1),
                         gset(V2,sp(I1-1),L1,L2),
                         reset(I,L2,LL)
                       );
                    L2=L
                 )
              );
          (
              K2 == 2 ->
                 (
                    gset(V2,V1,I,L,L1),
                    reset(I,L1,LL)
                 );
              (
                 M == 2 ->
                   (
                      pltest('gp-m-unify',[V1,V2,s],I,_,L,L1),
                      reset(I,L1,LL)
                   );
                 (
                    (
                      (M==3;K1==3;K2==3) ->
                         pltest_s('gp-unify-raw',[V1,V2,s],I,L,L1);
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
105
                      pltest_S('gp-unify',[V1,V2,s],I,L,L1)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
106 107 108 109 110 111 112 113
                    ),
                    reset(I,L1,LL)
                 )
              )
          )
      ).

   'unify-constant-2'(Code,V,I,L,LL) :-
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
114 115 116
      M is Code /\\ 3,
      A is (Code /\\ 4)  >> 2,
      K is (Code /\\ 24) >> 3,      
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
117 118

      (
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
119 120 121 122 123 124 125 126 127 128

        K == #f ->
          gset(V,c(C),I,L,LL);
          (
             M == #f ->
                (
                   pltest('gp-m-unify',[V,c(C),s],I,_,L,L2),
                   reset(I,L2,LL)
                );
             (
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
129 130 131
               (
                 (M=#t;K=#t) ->
                    pltest_s('gp-unify-raw',[V,c(C),s],I,L,L1);
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
132
                  pltest_s('gp-unify',[V,c(C),s],I,L,L1)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
133 134
               ),
               reset(I,L1,LL)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
135 136 137
             )
          )
      ).
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
138 139 140 141 142 143 144 145 146 147 148

   'unify-instruction'(C,M,I,II,L,LL) :-
       (
          M == #f ->
             pltest('gp_m_unify',[sp(I-1),c(C),s],I,_,L,L2);
          pltest_S('gp-unify-raw',[sp(I-1),c(C),s],I,L,L2)
       ),
       II is I - 1,
       reset(II,L2,LL)

")