vm-goal-model.scm 16.9 KB
Newer Older
1 2 3
(<define> (set_extended x)
  (<code> (set! unify_operators (combine_ops (<scm> x)))))

4 5 6 7 8
(<define> (gen x) (<=> x ,(gensym "disj")))
(<define> (gen-rec x) (<=> x ,(gensym "Rec")))

(<define> (get_consts x) (<=> x ,(get-consts)))

9
(compile-prolog-string "
10

11 12 13 14 15 16 17 18 19 20 21
reverse_op(<,>).
reverse_op(>,<).
reverse_op(=<,>=).
reverse_op(>=,=<).
reverse_op(@<,@>).
reverse_op(@>,@<).
reverse_op(@=<,@>=).
reverse_op(@>=,@=<).
reverse_op(=:=,=:=).
reverse_op(=\\=,=\\=).

22 23 24 25 26 27 28
rev(X,Y) :-
  rev(X,[],Y).

rev([],X,X).
rev([A|X],Y,Z) :-
  YY = [A|Y],
  rev(X,YY,Z).
29

30 31 32 33 34
zero(V)    :- get_A(V,A),A=[[0|_]].

print([]).
print([X|L]) :- write(X),nl,print(L).

35
wrap(Code,V,[L,LL]) :-
36 37 38 39
  catch(Code,E,
     (  
        tfc(E),
        (
40 41 42 43 44 45 46 47 48 49 50 51 52 53 54
           E==#t -> 
             (
               get_P(P0),
               L=[[[cc,P0]|LL],LL]
             );
           E==c  -> 
             (
                get_C(V,[[[P0,TagC2],_]|_]),
                set_P(V,P0),
                L=[[[cut,P0,TagC2],[fail,TagC2]|LL],LL]
             );
           (
              get_P(V,P0),
              L=[[[fail,P0]|LL],LL]
           )
55 56 57
        )
     )).

58
-trace.
59
-extended(',',m_and,;,m_or,\\+,m_not).
60
compile_goal(Code,Iout):- !,
61 62 63 64 65 66 67 68 69 70 71 72 73
  compile_goal(Code,Iout,StackSize,Narg,Consts,#t).

compile_goal(Code,Iout,StackSize,Narg,Constants,Pretty) :- !,
  (
    Code = (F(|A) :- Goal) -> length(A,Narg) ;
    Code = (F     :- Goal) -> Narg = 0       ;
    throw(compiles_only_clauses(Code))
  ),
  make_vhash(HV),
  make_vhash(HC),
  init_vars,init_e,
  (var(Constants) -> init_const ; true),
  b_setval(pretty,#t),
74
  make_state(0,[[0,_,_]],[],[[0,_]],0,0,0,0,0,[HC,HV],[],V),
75
  wrap(compile_goal(Code,#t,V,[L,[]]),V,[L,[]]),!,
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
76
  print(L),nl,!,
77 78
  get_M(V,StackSize),
  handle_all(L,LL),
79 80 81
  %(var(Constants)-> get_consts(Constants);true),
  %print(LL),nl,!,
  (true -> Iout=LL ; (b_setval(pretty,#f),mmtr(LL,Iout))).
82 83 84 85 86 87 88 89

compile_goal(X,Tail,V,L) :- var_p(X),!,
  compile_goal(call(X),Tail,V,L).


compile_goal(pr(X),Tail,V,[L,L]) :- !,
  write(pr(X)),nl.

90 91 92 93
compile_goal(set_p(Q),Tail,V,[L,LL]) :- !,
  get_P(V,P),
  L=[[set_p,Q,P]|LL].

94
compile_goal(!,Tail,V,[L,LL]) :- !,
95 96 97 98 99
  check_tail(Tail),
  get_C(V,[[[P0,TagC2],_]|_]),
  set_P(V,P0),
  (Tail==#t -> L=[[cut,P0,TagC2],[cc,TagC2]|LL] ; L=[[cut,P0,TagC2]|LL])
.
100
compile_goal(softie(A),Tail,V,[L,LLL]) :- !,
101
  check_tail(Tail),
102
  tail(Tail,V,LL,LLL),
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
103 104
  get_P(V,P),
  (Tail==#t -> L=[[softie,A],[cc,P]|LL] ; L=[[softie,A]|LL]).
105

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
106
compile_goal(begin_att,Tail,V,[L,LLL]) :- !,
107
   check_tail(Tail),
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
108
   tail(Tail,V,LL,LLL),
109 110 111 112 113 114 115 116 117 118
   (
     Tail==#t -> L=LLL ;
     (
       get_A(V,A),
       A=[[Ai  | _] | _],
       set_A(V,[[AAi,AAx,AAt] | A]),
       AAi is Ai + 1,
       var_p(AAx),
       add_var(AAx,V,Tagx),
       tr('pre-unify',Pre),
119 120
       get_P(V,P),
       L = [[Pre,AAt,Tagx,P]|LL]
121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144
     )
   ).

compile_goal(end_att,Tail,V,[L,LL]) :- !,
   check_tail(Tail),
   get_AF(V, A, F),
   [[Ai,Ax,At]|AA]=A,
   set_A(V, AA),
   (Ai==0  -> throw(missmatching_begin_end_pair) ; true),
   var_p(Ax),
   add_var(Ax,V,Tag),
   (Tail==#t -> tr('post-unify-tail',Post) ; tr('post-unify',Post)),      
   (
     Tail==#t ->  LLL=LL ; 
     (
       At==#t ->
         (
           tr('post-unicall',PostCall),
           get_C(V,[C|_]),
           LLL=[[PostCall,C,F]|LL]
         ) ;
         LLL=LL
     )
   ),
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
145
   get_P(V,P),
146 147
   (
      At   == #t  ->  L = [[Post,Tag]|LLL] ; 
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
148
      Tail == #t  ->  L = [[cc,P]|LLL]       ; 
149 150 151
                      L = LLL
   ).  

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
152
compile_goal(pop(N),Tail,V,[L,LLL]) :- !,
153 154 155
  check_tail(Tail),
  M is -N,
  push_v(M,V),
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
156 157
  tail(Tail,V,LL,LLL),
  L=[[pop,N]|LL].
158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177

compile_goal(with_cut(C,CS),Tail,V,[L,LL]) :- !,
  var_p(C),
  var_p(CS),
  add_var(C ,V,TagC ),
  add_var(CS,V,TagCS),
  L=[[cutter,TagC,TagCS]|LL].

compile_goal((Args <= Goal),Tail,V,L) :- !,
  (listp(Args) -> true ; throw(not_proper_head(Args <= goal))),
  reverse(Args,AArgs),
  mg(cc(|Args),AArgs,Impr,0,N),
  NN is N + 3,
  link_l(L,L1,L2,L3),
  compile_goal(Goal,label(G,NN),V,L1),
  L2=[[[label,G]|U],U],
  set_S(V,0),
  push_v(NN,V),
  compile_goal((begin_att,Impr,pop(3),end_att),Tail,V,L3).

178 179
compile_goal((F(|ASrgs) :- Goal),Tail,V,L) :- !,
  rev(ASrgs,Args),
180 181
  (listp(Args) -> true ; throw(not_proper_head(F(|Args)))),
  reverse(Args,AArgs),
182 183
  mg(F(|Args),AArgs,Impr,0,N),  
  push_v(N,V),
184
  get_A(V,[[0|_]|_]) ->
185
     wrap(compile_goal((move_args(0,N),begin_att,Impr,end_att,Goal),
186 187
                       Tail,V,L),V,L);
     wrap(compile_goal((move_args(0,N),begin_att,Impr,Goal),Tail,V,L),V,L).
188 189 190

compile_goal((F :- Goal),Tail,V,L) :- !,
  push_v(4,V),
191
  wrap(compile_goal((pop(4),Goal),Tail,V,L),V,L).
192

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
193 194 195
compile_goal(newtag_F(F),Tail,V,[L,LL]) :- !,
  check_tail(Tail),
  tail(Tail,V,L,LL),
196
  gen(F).
197 198 199 200

compile_goal(extended_off,Tail,V,[L,L]) :- !,
    set_extended(#f).

201 202
compile_goal(move_args(N,N),Tail,V,[L,LL]) :- !,
    L=[['handle-spcc',N]|LL].
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
203

204 205 206 207
compile_goal(move_args(K,N),Tail,V,[L,LL]) :- !,
    L=[push_at(K)|L1],
    KK is K + 1,
    compile_goal(move_args(KK,N),Tail,V,[L1,LL]).
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
208

209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226
compile_goal(extended_on(|L),Tail,V,[L,L]) :- !,
  set_extended(L).

compile_goal(extended_on,Tail,V,[L,L]) :- !,
  set_extended([]).
compile_goal(collect_F(F),Tail,V,[L,L]) :-
  get_F(V,F).

compile_goal(Op(\"recur\",Args),Tail,V,[L,LL]) :-    
   Args = F(|U),
   Op=\"op2*\",!,
   get_line(U,X,Xin,N),
   reverse(X,XX),
   mg(recur(|U),XX,Impr,0,N),
   add_recur(F,A,N),
   push_args_args(#f,Xin,V,L,L1,_,_),
   touch_A(V),
   touch_Q(10,V),
227 228
   %gen_rec(Sym)
   %set_F(V,Sym)
229 230 231 232 233 234 235
   L1=[[label,A]|L2],
   compile_goal((begin_att,Impr,end_att),Tail,V,[L2,LL]).

compile_goal((X,Y),Tail,V,L) :- !,
  collect_conj((X,Y),Gs,[]),
  compile_conj(Gs,Tail,V,L).

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
236
compile_goal(m_or(fail,false),#t,V,[[[fail,P],[cc,P] |L], L]) :-
237 238 239
   get_P(V,P).
compile_goal(m_or(fail,false),#f,V,[[[fail,P]      |L], L]) :-
   get_P(V,P).
240 241
compile_goal(true,_,_,_) :- throw(#t).
compile_goal(';'(|X),Tail,V,[L,LL]) :- !,
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
242
   write(disjTail(Tail)),nl,
243 244
   collect_disj(X,XX,[]),
   (
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
245
     XX=[]  -> L=[[flse]|LL]                ;
246 247
     XX=[Z] -> compile_goal(Z,Tail,V,[L,LL]) ; 
     (
248
       get_AB2ESM(V,Aq,B2,E,S,M),
249
       get_F(V,F), 
250
       Q=[_,_],
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
251
       compile_disjunction(XX,#t,Aq,Ae,Out,Lab,LabA,Tail,S,U,B2,V,LM,Q,QQ),!,
252
       (zero(V) -> Tp is 0 ; Tp is 1),
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
253
       pushl_Q(V,QQ),
254
       (
255
         varx(Q) ->
256
            (
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
257 258 259 260 261 262
              var_p(Var1),
              var_p(Var2),
              add_var_f(Var1,V,F,LabA1),
              add_var_f(Var2,V,F,LabA2),
              LabA = [LabA1,LabA2],
              L   = [['newframe-light',LabA,Lab,Q] | LX]
263 264
            ); 
            (
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
265 266 267 268 269 270
              var_p(Var1),
              var_p(Var2),
              add_var_f(Var1,V,F,LabA1),
              add_var_f(Var2,V,F,LabA2),
              LabA = [LabA1,LabA2],
              L   = [[newframe,LabA,Lab,Tp] | LX]   
271 272 273 274 275
            )
       ),
       LM = [LX,  [[label,Out] | LL]],
       get_EBH(V,Ed,B,H),
       add_missing_variables(H,U,Ed,Ed,EEd),!,
276 277 278
       BB2 is B2 \\/ EEd,
       EE is  E  \\/ EEd,
       set_B2E(V,BB2,EE)
279 280 281
     )
  ).

282
compile_goal(verbatim_call(X),Tail,V,[L,LL]) :- !,
283 284 285 286 287 288 289 290 291 292 293 294
   ( \\+var_p(X),
     ( 
       F(|Args)=X -> 
        (
          (var_p(F) ; isApply(Args)) -> fail ; true
        ) ; 
       true
     )
   ),
   !, 
   compile_goal(X,Tail,V,[L,LL]).

295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316
compile_goal(call(X),Tail,V,L) :- !,
   new_var(VS,V,TagS1),
   new_var(VP,V,TagP1),
   compile_goal(call_(X,A,Al,[C0|_],Pre,Post,LP),Tail,V,L),
   new_var(VS,V,TagS2),
   new_var(VP,V,TagP2),
   Ad=[A0,Cut_p],
   (
    A == #t ->
    ( 
     Cut_p == #t ->
     (
        Pre  = ['store-ps'   , A0, TagP1, TagS1    ],
        Post = [['goto-inst' , Out                 ],
                [label       , A0                  ],
                ['fail-psc'  , TagP1, TagS1, C0    ],
                [label       , Out                 ],
                ['post-sc'   , TagS1, C0           ]|LP]
     ) ; 
     (
       Pre  = [true],
       Post = LP
317
     )
318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337
    ) ;
    (
     Cut_p == #t ->
     (
        Pre  = ['store-p', A0, TagP1],
        Post = [['goto-inst' , Out          ],
                [label       , A0           ],
                ['fail-pc  ' ,TagP1, C0     ],
                [label       , Out          ],
                ['post-c'    , C0    ]|LP]
     ) ; 
     (
       Pre  = [true],
       Post = LP
     )
    )
  ).

compile_goal(call_(X,A0,Al,C0,Pre,Post,LP),Tail,V,[L,LL]) :- !,
   L=[Pre|LX],
338
   get_C(V,C),
339 340 341
   get_AA(V,A),
   AA = [A0|A],
   set_AA(V,AA),
342 343
   C  = [C0|_],
   CC = [Al|C],
344
   set_C(V,CC),
345
   compile_goal(X,#f,V,[LX,LLX]),
346
   set_AA(V,A),
347
   LLX = Post,
348
   set_C(V,C),
349
   LP=LL.
350

351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368
compile_goal((X =.. Y),Tail,V, L, LL) :- !,
  (var_p(X);constant(X)) ->
  (
     compile_arg(X,Branch,HC,HV,L,LLX),
     compile_imprint(Y,Branch,HC,HV,LLX,LLY),
     tr(=..,Op),
     LLY=[[Op]|LL]
  ).
  

compile_goal(set(V,X),Tail,V,[L,LL]) :- !,
  touch_Q(11,V),
  tr(set,Set),
  (var_p(X) -> true ; throw(no_var_in_set)),
  add_var(X,V,Tag),
  (isFirst(Tag) -> true ; force_variable(Tag)),
  push_args(X,V,L,LX),
  push_v(-1,V),
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
369
  get_P(V,P),
370 371
  (
    Tail=#t ->
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
372
       LX=[[Set,Tag],[cc,P]|LL];
373 374 375 376
       LX=[[Set,Tag]     |LL]  
  ).

compile_goal(once(G),Tail,V,[L,LL]) :- !,
377 378 379 380 381 382 383 384
  var_p(VP),
  var_p(VS),
  new_var(VP,V,TagP1),
  new_var(VS,V,TagS1),
  compile_goal(call_(G,A,Al,[C0|_],Pre,Post,LP),#f,V,[LX,LLX]),
  new_var(VP,V,TagP2),
  new_var(VS,V,TagS2),
  get_C(V,C),    
385
  Al=[A0,Cut_p],  
386
  (
387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417
    A==#t ->
    (
      Cut_p==#t ->
      (
        Pre  = ['store-ps'  , A0,TagP1,TagS1   ],
        Post = [['goto-inst' , Out              ],
                [label       , A0               ],
                [fail-psc    , TagP2,TagS2,C0   ],
                [label,Out                      ],
                ['softie-psc', TagP2,TagS2,C0   ]|LP]
      ) ;
      (
        Pre  = ['store-ps',TagP1,TagS1],
        Post = [['softie-ps',TagP2,TagS2]|LP]
      )
   ) ;
   (
     Cut_p==#t ->
      (
        Pre  = ['store-p',A0,TagP1],
        Post = [['goto-inst',Out],
                [label      ,A0],
                [fail-pc    ,TagP2,C0],
                [label,Out],
                ['softie-pc',TagP2,C0]|LP]
      ) ;
      (
        Pre  = [true],
        Post = LP
      )
   )
418 419 420 421 422 423 424 425
  ).
  
compile_goal((X->Y),Tail,V,L) :- !,
  compile_goal((once(X),Y),Tail,V,L).

compile_goal(\\+\\+\\+X,Tail,V,[L,LL]) :- !,
   compile_goal(\\+X,Tail,V,[L,LL]).

426
compile_goal(\\+\\+X,Tail,V,[L,LLL]) :- !,
427 428 429
   get_P(V,P0), 
   (P0=ground(_) -> PP=1 ; PP=0),
   A0 = [P0,TagC2],
430
   tail(Tail,V,LL,LLL),
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
431
   L=LX,
432
   get_QAESBB2(V,Q,AA,E,S,B,B2),
433
   set_QAE(V,[],[[0|_]],0),
434
   var_p(VP),   
435 436 437
   var_p(VS), 
   (PP=0 -> var_p(VP) ; true),
   get_F(V,F),
438 439
   add_var_f(VP,V,F,TagP1),
   add_var_f(VS,V,F,TagS1),
440
   (PP=0 -> add_var_f(VP,V,F,TagC1) ; true),
441
   compile_goal(call_(X,A,Ad,[C0|_],Pre,Post,LP),#f,V,[LX,LLX]),
442
   set_P(V,P0),
443 444
   add_var_f(VP,V,F,TagP2),
   add_var_f(VS,V,F,TagS2),
445
   (PP=0 -> add_var_f(VP,V,F,TagC2) ; true),
446
   set_QAESBB2(V,Q,AA,E,S,B,B2),
447 448
   (A=[[0|_]|_] -> Tp is 0 ; Tp is 1),
   Ad=[A0,Cut_p],
449

450 451 452 453 454
   ( 
    A==#t ->
    (
     Cut_p == #t ->
     (
455
       PP == 0 ->
456
       (
457 458
         Pre  = ['newframe-ps', TagP1, TagS1],
         Post = [['unwind-ps', TagP2, TagS2]|LP]
459 460
       ) ;
       (
461 462
         Pre  = ['newframe-psc', TagP1, TagS1, TagC1],
         Post = [['unwind-ps', TagP2, TagS2]|LP]
463
       )
464 465 466 467 468 469 470 471
     ) ;
     (
       Tp == 0 ->
       (
         Pre =  ['newframe-ps', TagP1, TagS1],
         Post = [['unwind-ps' , TagP2, TagS2]|LP]
       ) ;
       (
472 473
         Pre =  ['newframe-ps', TagP1, TagS1],
         Post = [['unwind-ps' , TagP2, TagS2]|LP]
474 475 476 477 478 479
       )
     )
    );
    (
     Cut_p == #t ->
     (
480 481 482 483 484 485 486 487 488
         PP=0 ->
            (
               Pre  = ['newframe-pc', TagP1, TagC1],
               Post = ['unwind-p', TagP1]
            );
         (
            Pre  = ['newframe-p', TagP1],
            Post = ['unwind-p', TagP1]
         )
489 490 491 492 493
     ) ;
     (
         Pre =  [true],
         Post = LP
     )
494
    )
495 496 497
 ).

compile_goal(\\+X,Tail,V,L) :- !,
498
  check_tail(Tail),
499 500 501 502
  new_var(VS,V,TagS1),
  new_var(VP,V,TagP1),
  new_var(VT,V,TagT1),
  get_QAESB(V,Q,A,E,S,B),
503
  
504 505
  ifc(
  (
506 507
     set_QAE(V,[],[[0|_]],0),
     compile_goal(call_(X,A,Ad,[C0|_],Pre,Post,LP),#f,V,L)
508 509 510 511 512 513
  ),Er,
  (   
      tfc(Er),
      (Er==#t -> throw(#f) ; throw(#t))
  ),
  (
514 515 516
    new_var(VS,V,TagS2),
    new_var(VP,V,TagP2),
    new_var(VT,V,TagT2),
517
    get_A(V,A1),
518
    set_QAESB(V,Q,A,E,S,B),
519
    (A=[[0|_]|_] -> Tp is 0 ; Tp is 1),
520
    Ad=[A0,Cut_p],
521
    
522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555
    ( 
     A==#t ->
     (
       Cut_p == #t ->
       (
         Tp == 0 ->
           (
              Pre  = ['newframe-psc',Al,TagP1,TagS1], 
              Post = [['fail-psc',TagP2,TagS2,C0],
                      [label,Al],
                      ['unwind-psc',TagP2,TagS2,C0]|LP]
          );
          (
              Pre  = ['newframe-psct',Al,TagP1,TagS1, TagT1], 
              Post = [['fail-psc',TagP2,TagS2,C0],
                      [label,Al],
                      ['unwind-psct',TagP2,TagS2,TagT2,C0]|LP]
          )
      ) ;
      (
        Tp == 0 ->
          (
            Pre  = ['newframe-ps',TagP1,TagS1],
            Post = [['fail-p',TagP2],
                    [label,Al],
                    ['unwind-ps',TagP2,TagS2]|LP]
          );
          (
            Pre  = ['newframe-pst',TagP1,TagS1,TagT1],
            Post = [['fail-p',TagP2],
                    [label,Al],
                    ['unwind-pst',TagP2,TagS2,TagT2]|LP]
          )
      )
556
     );
557 558 559 560 561 562 563 564 565 566 567 568 569 570
     (
       Cut_p == #t ->
       (
          Pre  = ['store-p',Al,TagP1], 
          Post = [['fail-pc',TagP2,C0],
                  [label,Al],
                  ['restore-pc',TagP2,C0]|LP]      
      ) ;
      (
         Pre  = ['store-p',Al,TagP1],
         Post = [['fail-p',TagP2],
                 [label,Al],
                 ['restore-p',TagP2]|LP]
      )
571
     )
572
    )
573
  )).
574 575 576


compile_goal((m_and(Op,m_or(<,>,=<,>=,=:=,=\\=,@<,@=<,@>,@>=)))(X,Y),
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
577 578
              Tail,V,[L,LLL]) :- !,
  write(compTail(Tail)),nl,
579
  check_tail(Tail),
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
580
  tail(Tail,V,LL,LLL),
581
  get_P(V,P),
582 583 584 585 586 587 588 589 590 591
  ifc(compile_scm(X,V,L,LX),EX,
     (
       ifc(compile_scm(Y,V,L,LY),EY,
          (
             call(Op(EX,EY)) -> throw(#t) ; throw(#f)
          ),
          (
              push_v(-1,V),
              reverse_op(Op,Or),
              binop1L(Or,O),
592

593
              tr(O,OO),
594
              LY=[[OO,P,EX]|LLL]
595 596 597 598 599 600 601
         ))
     ),
     ifc(compile_scm(Y,V,LX,LY),EY,
       (
         push_v(-1,V),
         binop1L(Op,O),
         tr(O,OO),
602
         LX=[[OO,P,EY]|LLL]
603 604 605 606 607
       ),
       (
         push_v(-2,V),
         tr(Op,OOp),
         binop(OOp,O),
608
         LY=[[Op,P]|LLL]
609 610 611 612 613 614 615
       ))).

compile_goal(X is Y,Tail,V,L) :- !,
    (zero(V) -> 
      compile_goal((begin_att,iss(X,Y),end_att),Tail,V,L);
      compile_goal(iss(X,Y),Tail,V,L)).

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
616
compile_goal(iss(X,Y),Tail,V,[L,LLL]) :- !,
617
  check_tail(Tail),
618
  tail(Tail,V,LL,LLL),
619 620 621 622 623 624 625 626 627 628 629
  (
    instruction(Y) ->
    (
      instruction(X) ->
      (
        X==Y -> throw(#t) ; throw(#f)
      );
      (
        tr('unify-instruction-2',Unify),
        var_p(X),
        add_var(X,V,Tag),
630
        L=[[Unify,Tag,Y,#t]|LL]
631
      )
632
    );    
633 634 635 636 637 638 639 640
    ifc(compile_scm(Y,V,L,LX),EY,compile_goal(X is EY, Tail, V, [L,LL]),
    (
      var_p(X)   ->   
       ( 
         add_var(X,V,Tag),
         (isFirst(Tag) -> true ; touch_Q(12,V)),
         push_v(-1,V),
         tr(unify,Unify),
641
         LX=[[unify,Tag,#t]|LL]
642 643 644 645 646 647 648 649
       );
       (
         (
          constant(X) ->
             tr('equal-constant',Equal) ; 
          tr('equal-instruction',Equal)
         ),
         push_v(-1,V),
650
         LX=[[Equal,X]|LL]
651 652 653 654 655 656 657 658 659 660 661 662
       )
    ))).
   
compile_goal(unify_with_occurs_check(X,Y),Tail,V,L) :- !,
  touch_Q(13,V),
  (
    X==Y    -> throw(#t) ;
    zero(V) -> 
      compile_goal((begin_att,uni_0(X,Y),end_att),Tail,V,L);
      compile_goal(uni_0(X,Y),Tail,V,L)
  ).

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
663
compile_goal(uni_0(X,Y),Tail,V,[L,LLL]) :- !,
664
  check_tail(Tail),
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
665 666
  compile_unify(X,Y,V,[L,LLL],0),
  tail(Tail,V,LL,LLL).
667 668 669 670 671 672 673 674 675 676 677


compile_goal(X = Y,Tail,V,L) :- !,
  touch_Q(14,V),
  (
    X==Y    -> throw(#t) ;
    zero(V) -> 
      compile_goal((begin_att,uni_x(X,Y),end_att),Tail,V,L);
      compile_goal(uni_x(X,Y),Tail,V,L)
  ).

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
678
compile_goal(uni_x(X,Y),Tail,V,[L,LLL]) :- !,
679
  check_tail(Tail),
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
680 681
  compile_unify(X,Y,V,[L,LL],#t),
  tail(Tail,V,LL,LLL).
682 683 684 685 686

compile_goal(X == Y,Tail,V,L) :- !,
  (
    X==Y    -> throw(#t) ;
    zero(V) -> 
687
      compile_goal((begin_att,unim(X,Y),end_att),Tail,V,L);
688 689 690
      compile_goal(uni(X,Y),Tail,V,L)
  ).

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
691
compile_goal(uni(X,Y),Tail,V,[L,LLL]) :- !,
692
  check_tail(Tail),
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
693 694
  compile_unify(X,Y,V,[L,LL],#t),
  tail(Tail,V,LL,LLL).
695

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
696
compile_goal(unim(X,Y),Tail,V,[L,LLL]) :- !,
697
  check_tail(Tail),
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
698 699
  compile_unify(X,Y,V,[L,LL],#f),
  tail(Tail,V,LL,LLL).
700

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
701
compile_goal(imprint(X,M),Tail,V,[L,LLL]) :- !,
702
  check_tail(Tail),
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
703 704
  compile_imprint(X,V,L,LL,M),
  tail(Tail,V,LL,LLL).
705

706
compile_goal(m_and(X,F(|AArgs)),Tail,V,L) :- !,
707
   (
708
    (var_p(F) ; isApply(AArgs)) -> compile_goal(call(X),Tail,V,L) ;
709 710
    (rev(AArgs,Args), caller(F,Args,Tail,V,L)),
    set_P(V,\"procedure\")
711 712 713 714 715 716 717 718 719 720 721 722 723
   ).

compile_goal(F,Tail,V,L) :-
  constant(F) -> (!,caller(F,[],Tail,V,L)).

compile_goal(X,_,_,_) :-
  throw(failed_compile_goal(X)).
      
isApply(X) :- var_p(X),!.
isApply([X|L]) :- isApply(L).

ncons(X,N) :-
  ncons(X,0,N).
724

725 726 727 728 729
")


(set! (@@ (logic guile-log guile-prolog vm vm-var) compile_goal)
  compile_goal)