[added first version of WAM stuff
gergo@complang.tuwien.ac.at**20081209115404] {
addfile ./wam.fs
hunk ./wam.fs 1
+\ representation of objects; first, tag definitions
+42 constant atom-tag
+4242 constant integer-tag
+424242 constant reference-tag
+42424242 constant unbound-tag
+4242424242 constant functor-tag
+424242424242 constant nil-tag
+42424242424242 constant list-tag
+
+\ now, creation and access methods; some of this could possibly be simpler
+\ using structures
+
+\ the first general access method simply gets the tag for any sort of
+\ object; this works because all of our objects have a tag cell right at the
+\ beginning
+: tag ( pl-obj -- tag )
+    @ ;
+
+\ atom layout: | tag | str-addr | str-u |
+: create-atom ( addr u -- atom )
+    { addr u }
+    noname create here ( atom )
+    atom-tag , addr , u ,
+    ;
+: atom-name ( atom -- addr u )
+    cell+ 2@ ( u addr )
+    swap ( addr u )
+    ;
+
+\ integer layout: | tag | n |
+: create-integer ( n -- integer )
+    { n }
+    noname create here ( integer )
+    integer-tag , n ,
+    ;
+: integer-value ( integer -- n )
+    cell+ @ ;
+
+\ reference layout: | tag | addr |
+: create-reference ( addr -- reference )
+    { addr }
+    noname create here ( reference )
+    reference-tag , addr ,
+    ;
+: dereference ( reference -- addr )
+    begin
+        dup tag reference-tag = while
+            cell+ @
+    repeat
+    ;
+
+\ unbound variable layout: | tag | addr |
+\ The address of an unbound variable is always invalid, so strictly
+\ speaking, we do not need to store it. However, we choose to store unbound
+\ variables as self-referencing variables.
+: create-unbound ( -- unbound )
+    noname create here
+    unbound-tag , dup ,
+    ;
+: unbind ( reference -- unbound )
+    \ Make the bound variable unbound. The result is the same pointer as
+    \ before, the memory it points to is changed.
+    dup dup cell+ !
+    dup unbound-tag swap !
+    ;
+
+: bind-reference ( obj unbound -- reference )
+    \ Change the unbound variable to a bound one.
+    reference-tag over !
+    ( obj unbound-with-ref-tag )
+    tuck cell+ !
+    ;
+
+\ functor layout: | tag | str-addr | str-u | arity | arg0 | ... | argN |
+: create-functor ( str-addr str-u arity -- functor )
+    { str-addr str-u arity }
+    noname create here
+    functor-tag , str-addr , str-u , arity ,
+    arity cells allot
+    ;
+: functor-name ( functor -- str-addr str-u )
+    \ make use of the fact that an atom's initial layout is identical to the
+    \ functor's
+    atom-name ;
+: functor-arity ( functor -- n )
+    3 cells + @ ;
+: functor-args ( functor -- addr )
+    4 cells + ;
+: arg, ( argptr val -- argptr' )
+    \ Store val at the argptr position, bump pointer.
+    over ! cell+ ;
+: lastarg ( argptr val -- )
+    \ Storing last arg, drop the pointer afterwards.
+    arg, drop ;
+
+\ nil layout: | tag |
+: create-nil ( -- nil )
+    noname create here
+    nil-tag ,
+    ;
+: is-nil ( pl-obj -- flag )
+    tag nil-tag = ;
+
+\ list layout: | tag | car | cdr |
+: create-list ( car cdr -- list )
+    { car cdr }
+    noname create here
+    list-tag , car , cdr ,
+    ;
+: is-list ( pl-obj -- flag )
+    tag list-tag = ;
+: list-args ( list -- addr )
+    cell+ ;
+: list-car ( list -- car )
+    cell+ @ ;
+: list-cdr ( list -- cdr )
+    2 cells + @ ;
+
+\ An unparser, for debugging and for printing bindings.
+: unparse ( pl-obj -- )
+    \ dup tag ." tag: " . cr
+    dup tag case
+        atom-tag of
+            atom-name type
+        endof
+        reference-tag of
+            dereference recurse
+        endof
+        unbound-tag of
+            \ print _G<address>; n 0 .r prints n without a space after it
+            ." _G" 0 .r
+        endof
+        functor-tag of
+            dup functor-name type
+            \ dup ." [[ functor arity: " functor-arity . ." ]]"
+            ." ("
+            dup functor-args ( functor arg0 )
+            dup @ recurse cell+ \ unparsed first arg, bumped pointer
+            ( functor arg1 )
+            swap functor-arity ( arg1 arity )
+            \ dup ." arity before loop: " . cr
+            1 u+do
+                ( argn )
+                ." , "
+                dup @ recurse cell+
+            loop
+            drop
+            ." )"
+        endof
+        nil-tag of
+            drop ." []"
+        endof
+        list-tag of
+            ." ["
+            dup list-car recurse
+            begin
+                list-cdr dereference dup is-list while
+                    ." , " ( cdr )
+                    dup list-car recurse
+            repeat
+            \ If there is anything left that's not a list and not nil, print
+            \ a cons; otherwise, we have nil, for which we need not print
+            \ anything.
+            dup is-nil invert if
+                ."  | " recurse
+            else
+                drop
+            endif
+            ." ]"
+        endof
+        \ default: can't happen
+        ( pl-obj tag )
+        ." *** oops: weird tag " . ." at address " . cr
+    endcase
+    ;
+
+\ unparse test case
+: test-unparse-1
+    s" func" 3 create-functor
+    dup functor-args
+        s" my_atom" create-atom arg,
+        create-unbound arg,
+        s" bar" create-atom create-nil create-list lastarg
+    unparse ;
+
+: test-unparse-2
+    s" a" create-atom { a }
+    s" b" create-atom { b }
+    b create-nil create-list create-reference { tail }
+    a tail create-list
+    unparse ;
+
+: test-unparse
+    cr
+    test-unparse-1 cr
+    test-unparse-2 cr
+    ;
+
+\ This is our choice point. It is also our format for deterministic stack
+\ frames; we use the same structure for both, although a few cells are
+\ unused in deterministic frames. Uniformity is more important.
+\ This does not include a continuation program pointer, which is essentially
+\ a return address. We implement calling a goal by calling a Forth word, so
+\ the Forth calling mechanism will take care of jumping back to the right
+\ place.
+struct
+    cell% field cp-b            \ previous choice point
+    cell% field cp-h            \ top of heap
+    cell% field cp-tr           \ top of trail
+    cell% field cp-bp           \ retry program counter (alternative clause)
+    cell% field cp-e            \ environment pointer
+    cell% 42 * field cp-args    \ argument/temporary registers
+end-struct choicepoint%
+
+\ Our three stacks. Note that the heap is below the environment stack; we
+\ take advantage of this in a few places.
+create heap 10000 cells allot
+create stack choicepoint% 100 * %allot
+stack choicepoint% %size 100 + constant stack-max
+create trail 100 cells allot
+
+\ Global state of the virtual machine: A structure that has the same format
+\ as a choice point, and the structure pointer.
+create global-state choicepoint% %allot
+stack global-state cp-b !
+heap global-state cp-h !
+trail global-state cp-tr !
+0 global-state cp-bp !
+variable global-s
+\ "Read" or "write" mode for unify instructions.
+23 constant read
+2323 constant write
+create global-mode 0 ,
+: enter-mode ( mode -- )
+    global-mode ! ;
+: mode ( -- mode )
+    global-mode @ ;
+
+: strcpy ( addr u -- addr' u )
+    { addr u }
+    noname create here ( addr' )
+    u chars allot
+    dup addr swap u ( addr' addr addr' u )
+    cmove
+    u ( addr' u )
+    ;
+
+create prolog-success -1 ,
+
+: push-choice-point ( -- )
+    global-state @ cp-b @ dup ( old-b old-b )
+    choicepoint% %size + ( old-b new-b )
+    dup stack-max >= if
+        s" stack overflow" exception throw
+    endif
+    ( old-b new-b )
+    2dup
+    choicepoint% %size move
+    ( old-b new-b )
+    tuck
+    cp-b !  \ store old value of b in new stack frame
+    ( new-b )
+    global-state @ cp-b !   \ store new value of b in global state
+    ;
+
+: pop-choice-point ( -- )
+    \ Fetch the stored old cp-b value and store it in the global b.
+    global-state cp-b @ cp-b @
+    global-state cp-b !
+    ;
+
+: trail-var ( var -- )
+    global-state cp-tr @ !
+    global-state cp-tr @ cell+ global-state cp-tr !
+    ;
+
+: set-s ( addr -- )
+    global-s !
+    ;
+
+
+: check-tag ( tag pl-obj -- flag )
+    tag = prolog-success ! ;
+
+\ fail
+: pl-fail ( -- )
+    \ failure replaces the current prolog success flag with 0
+    0 prolog-success !
+    ;
+create fail ' pl-fail ,
+
+\ Unification.
+defer unify-args
+
+: unify ( pl-obj1 pl-obj2 -- )
+    \ ." unify " over unparse ." ; " dup unparse cr
+
+    \ Trivial check first: If arguments are identical, they are unifiable.
+    2dup = if
+        2drop exit
+    endif
+
+    \ Make sure both arguments are fully dereferenced.
+    dereference swap
+    dereference swap
+
+    \ If one of the arguments is unbound, bind it to the other one. If both
+    \ are unbound, bind the one with the lower address.
+    over tag over tag
+    unbound-tag = swap
+    unbound-tag = swap
+    ( obj1 obj2 flag1 flag2 )
+    and if
+        ( obj1 obj2 )
+        2dup < if swap endif
+        \ Lower address is now on top, bind-reference binds top-of-stack to the
+        \ object below.
+        bind-reference
+        trail-var
+    else
+        over tag unbound-tag = if
+            \ Lower argument is a variable; bind and trail it.
+            swap
+            bind-reference
+            trail-var
+        else dup tag unbound-tag = if
+            \ Upper argument is a variable; bind and trail it.
+            bind-reference
+            trail-var
+    else
+        \ Both arguments are (somewhat) instantiated; they are definitely
+        \ only unifiable if their tags are equal.
+        ( obj1 obj2 )
+        over tag over tag = if
+            over tag case
+                atom-tag of
+                    ( obj1 obj2 )
+                    >r atom-name r> atom-name str= invert if
+                        pl-fail
+                    endif
+                endof
+                integer-tag of
+                    ( obj1 obj2 )
+                    integer-value swap integer-value <> if
+                        pl-fail
+                    endif
+                endof
+                functor-tag of
+                    ( obj1 obj2 )
+                    2dup
+                    >r functor-name r> functor-name str= >r
+                    over functor-arity over functor-arity = r> and if
+                        dup functor-arity >r
+                        functor-args swap functor-args swap r>
+                        unify-args
+                    else
+                        drop drop
+                        pl-fail
+                    endif
+                endof
+                nil-tag of
+                    ( obj1 obj2 )
+                    \ Nothing to do except pop off the two nils.
+                    drop drop
+                endof
+                list-tag of
+                    ( obj1 obj2 )
+                    list-args swap list-args swap 2
+                    unify-args
+                endof
+                \ default: can't happen
+                ." *** oops: weird tag " dup tag . ."  at address " . cr
+            endcase
+        else
+            ( obj1 obj2 )
+            drop drop
+            pl-fail
+        endif
+    endif endif endif
+    ;
+
+:noname ( argptr argptr n -- )
+    0 u+do
+        ( argptr argptr )
+        \ unify current args
+        over @ over @ unify
+        \ stop unifying if we failed
+        prolog-success 0 = if
+            leave
+        endif
+        \ bump pointers
+        cell+ swap cell+ swap
+    loop
+    ( argptr argptr )
+    drop drop
+    ; is unify-args
+
+: named-variable ( "name" -- unbound )
+    create-unbound
+    create ,
+    ;
+
+: unify-tester ( pl-obj pl-obj -- )
+    -1 prolog-success !
+    ." unifying terms  " over unparse ."   and  " dup unparse cr
+    unify
+    ." success: " prolog-success @ . cr
+    -1 prolog-success !
+    ;
+
+: test-unify-1
+    create-nil
+    s" foobar" create-atom
+    unify-tester
+    ;
+
+: test-unify-2
+    s" my_atom" create-atom
+    s" my_atom" create-atom
+    unify-tester
+    ;
+
+: test-unify-3
+    s" my_atom" create-atom
+    create-unbound
+    unify-tester
+    ;
+
+: test-unify-4
+    create-unbound create-nil create-list
+    create-unbound create-unbound create-list
+    unify-tester
+    ;
+
+: test-unify-5
+    create-unbound { x }   \ variable X
+    ." X = " x unparse cr
+    x create-nil create-list
+    x x create-list
+    unify-tester
+    ." X = " x unparse cr
+    ;
+
+: test-unify-6
+    \ Lambda = lambda(X, foo(X, X))
+    create-unbound { x }
+    s" foo" 2 create-functor { foo }
+        foo functor-args x arg, x lastarg
+    s" lambda" 2 create-functor { lambda }
+        lambda functor-args x arg, foo lastarg
+    create-unbound { lambda-var }
+    lambda lambda-var bind-reference
+    \ lambda(bar(a), Result)
+    s" a" create-atom { a }
+    s" bar" 1 create-functor { bar }
+        bar functor-args a lastarg
+    create-unbound { result-var }
+    s" lambda" 2 create-functor { lambda2 }
+        lambda2 functor-args bar arg, result-var lastarg
+    \ unify
+    ." Lambda = " lambda-var unparse cr
+    ." Result = " result-var unparse cr
+    lambda-var
+    lambda2
+    unify-tester
+    ." Lambda = " lambda-var unparse cr
+    ." Result = " result-var unparse cr
+    ;
+
+: test-unify
+    cr
+    test-unify-1 cr
+    test-unify-2 cr
+    test-unify-3 cr
+    test-unify-4 cr
+    test-unify-5 cr
+    test-unify-6 cr
+    ;
+
+
+\ Utility for testing WAM instructions: Set success flag, execute
+\ instruction, report success/failure, and set success again.
+: check-instr ( xt -- )
+    -1 prolog-success !
+    execute
+    ." success: " prolog-success @ .
+    -1 prolog-success ! ;
+
+: wam-instr-prologue
+    \ Stuff to be executed at the beginning of execution of every WAM
+    \ instruction. In particular, this generates code to check the current
+    \ success flag and skip the instruction's body if the flag is false.
+    POSTPONE prolog-success POSTPONE @ POSTPONE 0<> POSTPONE if
+    ; immediate compile-only
+
+: wam-instr:
+    :
+    POSTPONE wam-instr-prologue
+    ; immediate
+
+: wam-instr-epilogue
+    \ Generate the endif belonging to the if opened in the prologue.
+    POSTPONE endif
+    ; immediate compile-only
+
+: ;wam-instr
+    POSTPONE wam-instr-epilogue
+    POSTPONE ;
+    ; immediate compile-only
+
+\ Control instructions
+wam-instr: pl-execute ( flag xt -- )
+    \ The "tail call string" flag must be duplicated first.
+    over swap ( flag flag xt )
+    \ Executing a goal (in tail position) means calling the associated xt.
+    execute
+    \ Drop our duplicate flag.
+    drop
+    ;wam-instr
+
+defer print-solutions
+
+wam-instr: proceed ( flag -- flag )
+    \ In the WAM, the proceed instruction comes at the end of each fact, and
+    \ is responsible for jumping back to the caller. We do not need to do
+    \ that here, simply falling off the end of the clause will do. However,
+    \ in certain cases, we need to print solutions because proof of this
+    \ fact amounts to a proof of the user's goal. We therefore check the
+    \ "tail call sequence" flag, which is at the top of the stack.
+    dup if
+        print-solutions
+    endif
+    ;wam-instr
+
+\ Put instructions
+wam-instr: put_value ( vn ai -- )
+    \ Ai := Vn
+    swap @ swap !
+    ;wam-instr
+
+wam-instr: put_const ( n ai -- )
+    \ Ai := C
+    { n ai }
+    n create-integer ai !
+    ;wam-instr
+
+wam-instr: put_nil ( ai -- )
+    \ Ai := nil
+    { ai }
+    create-nil ai !
+    ;wam-instr
+
+wam-instr: put_list ( ai -- )
+    \ Ai := tag_list(H)
+    { ai }
+    0 0 create-list ai !
+    write global-mode !
+    ;wam-instr
+
+\ Get instructions
+wam-instr: get_variable ( vn ai -- )
+    \ Vn := Ai
+    { vn ai }
+    ai @ vn !
+    ;wam-instr
+
+wam-instr: get_value ( vn ai -- )
+    { vn ai }
+    vn @ ai @ unify
+    vn @ dereference vn !
+    ;wam-instr
+
+wam-instr: get_constant ( c ai -- )
+    { c ai }
+    ai @ dereference dup ( addr addr )
+    tag case
+        ( addr tag )
+        unbound-tag of
+            \ bind, trail
+            c swap bind-reference
+            trail-var
+        endof
+        atom-tag of
+            \ compare
+            atom-name c atom-name compare 0<> if
+                pl-fail
+            endif
+            \ if the names are equal, we are happy and fall off the end of
+            \ get_constant
+        endof
+        integer-tag of
+            integer-value c integer-value <> if
+                pl-fail
+            endif
+            \ ok, found equal integers
+        endof
+        \ default: the register refers to something that is definitely not
+        \ unifiable with the constant
+        pl-fail
+    endcase
+    ;wam-instr
+
+wam-instr: get_nil ( reg -- )
+    { reg }
+    reg @ dereference dup
+    tag case
+        ( addr tag )
+        unbound-tag of
+            \ bind, trail
+            create-nil swap bind-reference
+            trail-var
+        endof
+        nil-tag of
+            \ yippie, nothing to do
+        endof
+        \ default: cannot unify with list
+        pl-fail
+    endcase
+    ;wam-instr
+
+wam-instr: get_list ( reg -- )
+    { reg }
+    reg @ dereference dup
+    tag case
+        ( addr tag )
+        unbound-tag of
+            \ bind, trail, start write mode
+            0 0 create-list
+            ( var list )
+            tuck swap
+            ( list list var )
+            bind-reference ( list var )
+            trail-var ( list )
+            list-args set-s
+            write enter-mode
+        endof
+        list-tag of
+            \ look at arguments in read mode
+            list-args set-s
+            read enter-mode
+        endof
+        \ default: cannot unify with list
+        pl-fail
+    endcase
+    ;wam-instr
+
+wam-instr: unify_void ( n -- )
+    mode case
+        read of
+            ( n )
+            \ Bump the pointer stored in global-s by n cells.
+            cells global-s @ + global-s !
+        endof
+        write of
+            ( n )
+            \ Store n unbound variables, bumping global-s.
+            0 u+do
+                create-unbound global-s @ !
+                global-s @ cell+ set-s
+            loop
+        endof
+    endcase
+    ;wam-instr
+
+wam-instr: unify_variable ( vn -- )
+    { vn }
+    mode write = if
+        create-unbound global-s @ !
+    endif
+    global-s @ @ vn !
+    global-s @ cell+ set-s
+    ;wam-instr
+
+wam-instr: unify_value ( vn -- )
+    { vn }
+    mode case
+        read of
+            global-s @ @ vn @ unify
+            dereference
+            vn !
+            global-s @ cell+ set-s
+        endof
+        write of
+            vn @ global-s @ !
+            global-s @ cell+ set-s
+        endof
+    endcase
+    ;wam-instr
+
+\ words to define:
+\ try_me_else trust_me_else
+defer set-alternative
+wam-instr: try_me_else ( xt -- )
+    set-alternative
+    push-choice-point
+    ;wam-instr
+wam-instr: trust_me_else ( xt -- )
+    pop-choice-point
+    \ In practice, this will always be called with the fail xt. Thus setting
+    \ the alternative is absolutely unnecessary. But let's do it anyway.
+    set-alternative
+    push-choice-point
+    ;wam-instr
+\ C1a C1 C2a C2 ...
+create C1a ' abort ,  create C1 ' abort ,
+create C2a ' abort ,  create C2 ' abort ,
+create C3a ' abort ,  create C3 ' abort ,
+create C4a ' abort ,  create C4 ' abort ,
+create C5a ' abort ,  create C5 ' abort ,
+create C6a ' abort ,  create C6 ' abort ,
+create C7a ' abort ,  create C7 ' abort ,
+create C8a ' abort ,  create C8 ' abort ,
+create C9a ' abort ,  create C9 ' abort ,
+\ a1 a2 a3 ...
+: a1 global-state cp-args 0 cells + ;
+: a2 global-state cp-args 1 cells + ;
+: a3 global-state cp-args 2 cells + ;
+: a4 global-state cp-args 3 cells + ;
+: a5 global-state cp-args 4 cells + ;
+: a6 global-state cp-args 5 cells + ;
+: a7 global-state cp-args 6 cells + ;
+: a8 global-state cp-args 7 cells + ;
+: a9 global-state cp-args 8 cells + ;
+: a10 global-state cp-args 9 cells + ;
+: a11 global-state cp-args 10 cells + ;
+: a12 global-state cp-args 11 cells + ;
+: a13 global-state cp-args 12 cells + ;
+: a14 global-state cp-args 13 cells + ;
+: a15 global-state cp-args 14 cells + ;
+: a16 global-state cp-args 15 cells + ;
+: a17 global-state cp-args 16 cells + ;
+: a18 global-state cp-args 17 cells + ;
+: a19 global-state cp-args 18 cells + ;
+: a20 global-state cp-args 19 cells + ;
+: a21 global-state cp-args 20 cells + ;
+: a22 global-state cp-args 21 cells + ;
+: a23 global-state cp-args 22 cells + ;
+: a24 global-state cp-args 23 cells + ;
+: a25 global-state cp-args 24 cells + ;
+: a26 global-state cp-args 25 cells + ;
+: a27 global-state cp-args 26 cells + ;
+: a28 global-state cp-args 27 cells + ;
+: a29 global-state cp-args 28 cells + ;
+: a30 global-state cp-args 29 cells + ;
+: a31 global-state cp-args 30 cells + ;
+: a32 global-state cp-args 31 cells + ;
+: a33 global-state cp-args 32 cells + ;
+: a34 global-state cp-args 33 cells + ;
+: a35 global-state cp-args 34 cells + ;
+: a36 global-state cp-args 35 cells + ;
+: a37 global-state cp-args 36 cells + ;
+: a38 global-state cp-args 37 cells + ;
+: a39 global-state cp-args 38 cells + ;
+: a40 global-state cp-args 39 cells + ;
+: a41 global-state cp-args 40 cells + ;
+: a42 global-state cp-args 41 cells + ;
+\ x1 x2 x3 ...
+: x1 global-state cp-args 0 cells + ;
+: x2 global-state cp-args 1 cells + ;
+: x3 global-state cp-args 2 cells + ;
+: x4 global-state cp-args 3 cells + ;
+: x5 global-state cp-args 4 cells + ;
+: x6 global-state cp-args 5 cells + ;
+: x7 global-state cp-args 6 cells + ;
+: x8 global-state cp-args 7 cells + ;
+: x9 global-state cp-args 8 cells + ;
+: x10 global-state cp-args 9 cells + ;
+: x11 global-state cp-args 10 cells + ;
+: x12 global-state cp-args 11 cells + ;
+: x13 global-state cp-args 12 cells + ;
+: x14 global-state cp-args 13 cells + ;
+: x15 global-state cp-args 14 cells + ;
+: x16 global-state cp-args 15 cells + ;
+: x17 global-state cp-args 16 cells + ;
+: x18 global-state cp-args 17 cells + ;
+: x19 global-state cp-args 18 cells + ;
+: x20 global-state cp-args 19 cells + ;
+: x21 global-state cp-args 20 cells + ;
+: x22 global-state cp-args 21 cells + ;
+: x23 global-state cp-args 22 cells + ;
+: x24 global-state cp-args 23 cells + ;
+: x25 global-state cp-args 24 cells + ;
+: x26 global-state cp-args 25 cells + ;
+: x27 global-state cp-args 26 cells + ;
+: x28 global-state cp-args 27 cells + ;
+: x29 global-state cp-args 28 cells + ;
+: x30 global-state cp-args 29 cells + ;
+: x31 global-state cp-args 30 cells + ;
+: x32 global-state cp-args 31 cells + ;
+: x33 global-state cp-args 32 cells + ;
+: x34 global-state cp-args 33 cells + ;
+: x35 global-state cp-args 34 cells + ;
+: x36 global-state cp-args 35 cells + ;
+: x37 global-state cp-args 36 cells + ;
+: x38 global-state cp-args 37 cells + ;
+: x39 global-state cp-args 38 cells + ;
+: x40 global-state cp-args 39 cells + ;
+: x41 global-state cp-args 40 cells + ;
+: x42 global-state cp-args 41 cells + ;
+\ generator:
+\ :noname 42 0 do ." : a" i 1+ . ." global-state cp-args " i . ." cells + ;" cr loop ;
+
+\ switch_on_term
+wam-instr: switch_on_term ( xt1 xt2 xt3 xt4 -- )
+    \ Depending on type of a1 (variable, constant, non-empty list,
+    \ structure), jump to one of the clauses given as xts.
+    { xt1 xt2 xt3 xt4 }
+    a1 @ dereference tag case
+        unbound-tag     of xt1 endof
+        reference-tag   of xt1 endof
+
+        atom-tag        of xt2 endof
+        nil-tag         of xt2 endof
+
+        list-tag        of xt3 endof
+
+        functor-tag     of xt4 endof
+    endcase
+    execute
+    ;wam-instr
+
+\ definition of concatenate/3 from Warren's WAM document:
+\ concatenate([],L,L).
+\ concatenate([X|L1],L2,[X|L3]) :- concatenate(L1,L2,L3).
+\ this does not use permanent variables, which is nice
+defer concatenate
+
+: C1a-def
+    C2a try_me_else                 \ concatenate(
+    C1 pl-execute ;
+' C1a-def is C1a
+: C1-def
+    a1 get_nil                      \   [],
+    a2 a3 get_value                 \   L,L
+    proceed                         \ ).
+    ;
+' C1-def is C1
+
+: C2a-def
+    fail trust_me_else              \ concatenate(
+    C2 pl-execute ;
+' C2a-def is C2a
+: C2-def
+    a1 get_list                     \   [
+    x4 unify_variable               \       X|
+    a1 unify_variable               \       L1], L2,
+    a3 get_list                     \   [
+    x4 unify_value                  \       X|
+    a3 unify_variable               \       L3]) :-
+    ['] concatenate pl-execute      \ concatenate(L1,L2,L3).
+    ;
+' C2-def is C2
+
+:noname
+    C1a C1 C2 fail switch_on_term
+    ( result )
+    if
+        ." Yes!" cr
+    else
+        ." No :-(" cr
+    endif ; is concatenate
+
+: concat-code-1
+    \ Debug: One pass through the recursive clause, then the fact.
+    \ ~~
+    a1 get_list                     \   [
+    \ ~~
+    x4 unify_variable               \       X|
+    \ ~~
+    a1 unify_variable               \       L1], L2,
+    ~~
+    a3 get_list                     \   [
+    ~~
+    x4 unify_value                  \       X|
+    ~~
+    a3 unify_variable               \       L3]) :-
+    ~~
+
+    a1 get_nil                      \   [],
+    ~~
+    \ ." a2 = " a2 @ unparse cr
+    \ ." a3 = " a3 @ unparse cr
+    a2 a3 get_value                 \   L,L
+    \ ~~
+    ;
+
+: concat-test-1
+    \ concatenate([a], [b], L).
+    s" a" create-atom create-nil create-list a1 !
+    s" b" create-atom create-nil create-list a2 !
+    create-unbound { l }
+    l a3 !
+    ." L = " l unparse cr
+    ." calling code (unroll 1) for concatenate([a], [b], L)" cr
+    concat-code-1
+    ." success: " prolog-success @ . cr
+    ." L = " l unparse cr
+    ;
+
+: concat-test-2
+    \ concatenate([a], [X], [a, b]).
+    s" a" create-atom create-nil create-list a1 !
+    create-unbound { x }
+    x create-nil create-list a2 !
+    ." X = " x unparse cr
+    s" b" create-atom create-nil create-list { tail }
+    s" a" create-atom tail create-list a3 !
+    create-unbound x4 !
+    ." calling code (unroll 1) for concatenate([a], [X], [a, b])" cr
+    concat-code-1
+    ." success: " prolog-success @ . cr
+    ." X = " x unparse cr
+    ;
+
+: concat-tests
+    cr
+    concat-test-1 cr
+    concat-test-2
+    ;
+
+clearstack
}