[Tons of fixes, backtracking *really* works now. New append example.
Gergö Barany <gergo@complang.tuwien.ac.at>**20090122213039] {
hunk ./wam.fs 569
+: wam-unary-instr-epilogue
+    POSTPONE else
+        POSTPONE drop
+    POSTPONE endif
+    ; immediate compile-only
+
+: wam-binary-instr-epilogue
+    POSTPONE else
+        POSTPONE drop
+        POSTPONE drop
+    POSTPONE endif
+    ; immediate compile-only
+
hunk ./wam.fs 587
+: ;unary-wam-instr
+    POSTPONE wam-unary-instr-epilogue
+    POSTPONE ;
+    ; immediate compile-only
+
+: ;binary-wam-instr
+    POSTPONE wam-binary-instr-epilogue
+    POSTPONE ;
+    ; immediate compile-only
+
hunk ./wam.fs 599
+  \ ." pl-execute" cr
hunk ./wam.fs 607
-    alternative fail <> if
-      \ ." trying alternative clause " alternative . cr
-      \ The alternative pointer is not equal to fail. That is, there is an
-      \ alternative; execute it! I think this means we must pop the choice
-      \ point here.
-      pop-choice-point
-      alternative recurse
+  \ ." success at retry: " prolog-success @ . cr
+  \ ." alternative: " alternative . cr
+    prolog-success @ 0 = if
+        fail alternative <> if
+            -1 prolog-success !
+            pop-choice-point
+            alternative recurse
+        else
+          \ ." alternative is fail" cr
+        endif
hunk ./wam.fs 618
-    ;wam-instr
+    ;unary-wam-instr
hunk ./wam.fs 621
-:noname ; is print-solutions
+: empty-print-solutions
+    ." <should be printing solutions here>" cr
+    ;
+' empty-print-solutions is print-solutions
hunk ./wam.fs 636
-      \ TODO: Ask whether to search for additional solutions?
+        ." ;" cr
+      \ TODO: Ask whether to search for additional solutions!
+      \ ." trying alternatives after solution" cr
+        global-state cp-bp @ { alternative }
+      \ ." alternative is: " alternative . cr
+        pop-choice-point
+        alternative pl-execute
hunk ./wam.fs 650
-    ;wam-instr
+    ;binary-wam-instr
hunk ./wam.fs 656
-    ;wam-instr
+    ;binary-wam-instr
hunk ./wam.fs 662
-    ;wam-instr
+    ;unary-wam-instr
hunk ./wam.fs 669
-    ;wam-instr
+    ;unary-wam-instr
hunk ./wam.fs 676
-    ;wam-instr
+    ;binary-wam-instr
hunk ./wam.fs 682
-    ;wam-instr
+    ;binary-wam-instr
hunk ./wam.fs 712
-    ;wam-instr
+    ;binary-wam-instr
hunk ./wam.fs 734
-    ;wam-instr
+    ;unary-wam-instr
hunk ./wam.fs 758
+        drop
hunk ./wam.fs 761
-    ;wam-instr
+    ;unary-wam-instr
hunk ./wam.fs 779
-    ;wam-instr
+    ;unary-wam-instr
hunk ./wam.fs 788
-    ;wam-instr
+    ;unary-wam-instr
hunk ./wam.fs 803
-    ;wam-instr
+    ;unary-wam-instr
hunk ./wam.fs 821
-    ;wam-instr
+    ;unary-wam-instr
+wam-instr: retry_me_else ( xt -- )
+    set-alternative
+    ;unary-wam-instr
hunk ./wam.fs 837
-    ;wam-instr
+    ;unary-wam-instr
hunk ./wam.fs 1040
-: concatenate-shell
-    \ Set "tail call" flag.
-    -1
+: prolog-shell ( xt -- )
+    \ Set "tail call" flag below the xt.
+    -1 swap
hunk ./wam.fs 1044
-    concatenate
+    pl-execute
hunk ./wam.fs 1069
+create global-ct1-l 0 ,
+: concat-test-1-print-solutions
+    ." L = " global-ct1-l @ unparse cr
+    ;
+
hunk ./wam.fs 1076
+    { xt }
+    ['] concat-test-1-print-solutions is print-solutions
hunk ./wam.fs 1080
-    create-unbound { l }
-    l a3 !
-  \ ." L = " l unparse cr
+    create-unbound global-ct1-l !
+    global-ct1-l @ a3 !
hunk ./wam.fs 1083
-    \ concat-code-1
-    concatenate-shell
-    ." L = " l unparse cr
+    xt prolog-shell
+    ;
+
+create global-ct2-x 0 ,
+: concat-test-2-print-solutions
+    ." X = " global-ct2-x @ unparse cr
hunk ./wam.fs 1093
+    { xt }
+    ['] concat-test-2-print-solutions is print-solutions
hunk ./wam.fs 1096
-    create-unbound { x }
-    x create-nil create-list a2 !
-  \ ." X = " x unparse cr
+    create-unbound global-ct2-x !
+    global-ct2-x @ create-nil create-list a2 !
hunk ./wam.fs 1102
-    \ concat-code-1
-    concatenate-shell
-    ." X = " x unparse cr
+    xt prolog-shell
+    ;
+
+create global-ct3-a-var 0 ,
+create global-ct3-d-var 0 ,
+create global-ct3-rest-var 0 ,
+: concat-test-3-print-solutions
+    ." A = " global-ct3-a-var @ unparse cr
+    ." D = " global-ct3-d-var @ unparse cr
+    ." Rest = " global-ct3-rest-var @ unparse cr
hunk ./wam.fs 1116
+    { xt }
+    ['] concat-test-3-print-solutions is print-solutions
hunk ./wam.fs 1122
-    create-unbound { d-var }
-    d-var create-nil create-list { list2 }
-    create-unbound { a-var }
-    create-unbound { rest-var }
-    a-var rest-var create-list { list3 }
-  \ ." A = " a-var unparse cr
-  \ ." D = " d-var unparse cr
-  \ ." Rest = " rest-var unparse cr
+    create-unbound global-ct3-d-var !
+    global-ct3-d-var @ create-nil create-list { list2 }
+    create-unbound global-ct3-a-var !
+    create-unbound global-ct3-rest-var !
+    global-ct3-a-var @ global-ct3-rest-var @ create-list { list3 }
hunk ./wam.fs 1131
-    concatenate-shell
-    ." A = " a-var unparse cr
-    ." D = " d-var unparse cr
-    ." Rest = " rest-var unparse cr
+    xt prolog-shell
hunk ./wam.fs 1134
-create global-a-var 0 ,
-create global-b-var 0 ,
-:noname ( -- )
-    global-a-var @ 0<> if
-        ." A = " global-a-var @ unparse ." ," cr
+create global-ct4-a-var 0 ,
+create global-ct4-b-var 0 ,
+: concat-test-4-print-solutions ( -- )
+    global-ct4-a-var @ 0<> if
+        ." A = " global-ct4-a-var @ unparse cr
hunk ./wam.fs 1140
-    global-b-var @ 0<> if
-        ." B = " global-b-var @ unparse ."  ;" cr cr
+    global-ct4-b-var @ 0<> if
+        ." B = " global-ct4-b-var @ unparse cr
hunk ./wam.fs 1143
-    ; is print-solutions
+    ;
hunk ./wam.fs 1147
-    create-unbound global-a-var !
-    create-unbound global-b-var !
+    { xt }
+    ['] concat-test-4-print-solutions is print-solutions
+    create-unbound global-ct4-a-var !
+    create-unbound global-ct4-b-var !
hunk ./wam.fs 1154
-    global-a-var @ a1 !
-    global-b-var @ a2 !
+    global-ct4-a-var @ a1 !
+    global-ct4-b-var @ a2 !
hunk ./wam.fs 1158
-    concatenate-shell
+    xt prolog-shell
hunk ./wam.fs 1164
-: concat-tests
+\ This can now be used with several different predicate definitions that
+\ pretend to be concatenate...
+\ Run with:   ' concatenate concat-tests    or    ' append concat-tests
+: concat-tests ( xt -- )
+    { xt }
hunk ./wam.fs 1170
-    concat-test-1 cr
-    concat-test-2 cr
-    concat-test-3 cr
-    concat-test-4 cr
+    -1 prolog-success !
+    xt concat-test-1 cr
+    -1 prolog-success !
+    xt concat-test-2 cr
+    -1 prolog-success !
+    xt concat-test-3 cr
+    -1 prolog-success !
+    xt concat-test-4 cr
hunk ./wam.fs 1184
+\ Simpler shot at concatenate, without indexing instructions. Renamed this
+\ to append to avoid name clashes (redefinitions, actually, which would be
+\ harmless).
+\ This is meant to be a model for what should be generated by the compiler.
+\ Note that the last clause's alternative is fail; this way, the compiler
+\ should be able to generate code one clause at a time without any
+\ lookahead.
+\ For clause N of predicate P, define:
+\ -  a variable P-clause-(N+1)
+\ -  a colon definition of P-clause-N-def
+\ -  a store of the xt of P-clause-N-def into P-clause-N
+\ Via the variable for clause N+1, any clause can indirectly refer to its
+\ immediate successor to set it as an alternative.
+
+\ begin code for clause 1 of append
+create append-clause-2 0 ,
+: append-clause-1-def
+    append-clause-2 @ try_me_else
+    a1 get_nil
+    a2 a3 get_value
+    proceed ;
+\ end code for clause 1 of append
+
+\ end code for clause 2 of append
+create append-clause-3 0 ,
+: append-clause-2-def
+    append-clause-3 @ retry_me_else
+    a1 get_list
+    x4 unify_variable
+    a1 unify_variable
+    a3 get_list
+    x4 unify_value
+    a3 unify_variable
+    ['] append-clause-1-def pl-execute ;
+' append-clause-2-def append-clause-2 !
+\ end code for clause 2 of append
+
+\ begin code for clause 3 of append
+fail append-clause-3 !
+\ end code for clause 3 of append
+
+: append append-clause-1-def ;
+
+\ ." append clause 1: " ' append-clause-1-def . cr
+\ ." append clause 2: " ' append-clause-2-def . cr
+\ ." append clause 3: " fail . cr
+
}