\ representation of objects; first, tag definitions
\ 2009-01-24: Rearranged to make ordering easier.
42 constant reference-tag
4242 constant unbound-tag
424242 constant integer-tag
42424242 constant atom-tag
4242424242 constant nil-tag
424242424242 constant functor-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 ." ptr: " . cr
\ dup tag ." tag: " . cr
dup tag case
atom-tag of
atom-name type
endof
integer-tag of
integer-value 0 .r
endof
reference-tag of
dereference recurse
endof
unbound-tag of
\ print _G
; 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.
\ The above comment is nonsense. We do not use the heap at all! Instead, we
\ allocate our structures in the dictionary. The heap would only be relevant
\ if we were to use a more intelligent memory management scheme.
\ create heap 10000 cells allot
choicepoint% 100 * %allot constant stack
choicepoint% %size 100 * stack + constant stack-max
create trail 100 cells allot
\ This is the environment stack that holds permanent variables. In real WAM,
\ these environment frames share a stack with choicepoints. For our
\ purposes, it's OK to have them separate.
create environment-stack 10000 cells allot
\ Global state of the virtual machine: A structure that has the same format
\ as a choice point, and the structure pointer.
choicepoint% %allot constant global-state
stack global-state cp-b !
\ heap global-state cp-h !
trail global-state cp-tr !
' abort global-state cp-bp !
environment-stack global-state cp-e !
variable global-s
\ Some flags...
create interactive-mode 0 ,
create stop-search 0 ,
\ Some flag manipulation words...
: on ( ptr -- )
-1 swap !
;
: off ( ptr -- )
0 swap !
;
: flag-set? ( ptr -- )
@
;
\ "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 !
\ ;
: push-choice-point
\ ." *** pushing cp" cr
\ Old and new B stack pointers.
global-state cp-b @ { b }
b choicepoint% %size + { new-b }
\ Overflow check.
new-b stack-max >= if
s" Prolog choicepoint stack overflow" exception throw
endif
\ Copy current state to choicepoint stack.
global-state new-b choicepoint% %size move
\ Update B stack pointer.
new-b global-state cp-b !
;
: pop-choice-point
\ ." *** popping cp" cr
\ Pop.
global-state cp-b @ { prev-cp }
\ Underflow check.
prev-cp stack <= if
s" Prolog choicepoint stack underflow" exception throw
endif
\ Trail variables: Make all variables between the top-of-trail and the
\ previous top-of-trail unbound.
global-state cp-tr { trailptr }
\ ." trailptr: " trailptr @ . cr
prev-cp cp-tr @ { top-of-trail }
\ ." top-of-trail: " top-of-trail . cr
begin
trailptr @ top-of-trail > while
trailptr @ cell - trailptr !
\ ." unbinding " trailptr @ . ." / " trailptr @ @ . cr
\ trailptr @ @ tag . cr
trailptr @ @ unbind
\ unbind leaves the pointer to the variable (now unbound) on the
\ stack, but we don't need it here anymore.
drop
repeat
\ Copy old choicepoint into current state.
prev-cp global-state choicepoint% %size move
;
: set-alternative ( xt -- )
\ ." set-alternative " dup . cr
\ Set the current choice point's alternative pointer to xt.
global-state cp-bp !
;
: trail-var ( var -- )
\ ." trailing " dup . ." : "
global-state cp-tr @ !
\ global-state cp-tr @ . ." -> "
global-state cp-tr @ cell+ global-state cp-tr !
\ global-state cp-tr @ . cr
;
: 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 ,
' pl-fail global-state cp-bp !
\ 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
drop 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-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
: wam-ternary-instr-epilogue
POSTPONE else
POSTPONE drop
POSTPONE drop
POSTPONE drop
POSTPONE endif
; immediate compile-only
: wam-quaternary-instr-epilogue
POSTPONE else
POSTPONE drop
POSTPONE drop
POSTPONE drop
POSTPONE drop
POSTPONE endif
; immediate compile-only
: ;wam-instr
POSTPONE wam-instr-epilogue
POSTPONE ;
; immediate compile-only
: ;unary-wam-instr
POSTPONE wam-unary-instr-epilogue
POSTPONE ;
; immediate compile-only
: ;binary-wam-instr
POSTPONE wam-binary-instr-epilogue
POSTPONE ;
; immediate compile-only
: ;ternary-wam-instr
POSTPONE wam-ternary-instr-epilogue
POSTPONE ;
; immediate compile-only
: ;quaternary-wam-instr
POSTPONE wam-quaternary-instr-epilogue
POSTPONE ;
; immediate compile-only
\ Control instructions
defer try-alternatives
wam-instr: pl-execute-xt ( flag xt -- flag )
\ ." pl-execute-xt" cr
\ If this is in interactive mode, and the user doesn't want any more
\ solutions, don't print any.
interactive-mode flag-set? stop-search flag-set? and if
drop
exit
endif
\ 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
dup try-alternatives
;unary-wam-instr
wam-instr: pl-execute ( flag addr u -- flag )
\ ." *** pl-execute "
\ 2dup type cr
evaluate ( flag xt )
\ ." xt = " dup . cr
pl-execute-xt
;binary-wam-instr
wam-instr: pl-call-xt ( xt -- )
\ If this is in interactive mode, and the user doesn't want any more
\ solutions, don't print any.
interactive-mode flag-set? stop-search flag-set? and if
drop
exit
endif
\ The new "tail call flag" is 0, because this is *not* a tail call.
0 swap
\ Call the goal.
execute
\ Drop the flag.
drop
\ Backtrack if necessary.
dup try-alternatives
;unary-wam-instr
wam-instr: pl-call ( addr u -- )
evaluate ( xt )
pl-call-xt
;binary-wam-instr
:noname ( flag -- )
\ FIXME: Alternative solutions for split(Xs, 3, [1,2], [4,5]) are not
\ found using this code.
global-state cp-bp @ { alternative }
\ ." success at retry: " prolog-success @ . cr
\ ." alternative: " alternative . cr
prolog-success @ 0 = if
['] pl-fail alternative <> if
-1 prolog-success !
global-state cp-b @ stack > if
pop-choice-point
endif
( flag )
0= if
global-state cp-bp @ pl-call-xt
else
global-state cp-bp @ pl-execute-xt
endif
else
\ ." alternative is fail" cr
global-state cp-b @ stack > if
\ ." cp-b @ = " global-state cp-b @ .
\ ." , stack = " stack .
\ ." , trying to pop choice point to retry" cr
pop-choice-point
\ -1 prolog-success !
recurse
endif
endif
endif
; is try-alternatives
:noname ( flag -- )
begin
\ Find a choice point with a non-fail alternative, if any.
['] pl-fail global-state cp-bp @ =
global-state cp-b @ stack > and while
pop-choice-point
repeat
global-state cp-bp @ { alternative }
['] pl-fail alternative <> if
\ Found one, retry.
-1 prolog-success !
( flag )
0= if
alternative pl-call
else
alternative pl-execute-xt
endif
endif
; \ is try-alternatives
create query-var-space 100 3 * cells allot
create query-var-ptr query-var-space ,
: clear-query-vars ( -- )
query-var-space query-var-ptr !
0 query-var-ptr @ !
;
: register-query-var ( addr u regnum -- )
\ ." *** register " -rot 2dup type ." with regnum " rot dup . cr
query-var-ptr @ 2 cells + !
query-var-ptr @ cell+ !
query-var-ptr @ !
query-var-ptr @ 3 cells + query-var-ptr !
;
defer print-solutions
: default-print-solutions ( -- )
\ dup 2dup -1 <> 0 <> and if ." foo = " unparse cr else drop endif
query-var-ptr @ query-var-space = if
." " cr
else
query-var-ptr @
begin
( ptr )
dup query-var-space > while
3 cells -
dup 2 cells + @ 1 - cells environment-stack + { reg }
dup cell+ @ { u }
dup @ { addr }
addr u type ." = " reg @ unparse cr
repeat
( ptr )
drop
endif
;
' default-print-solutions is print-solutions
wam-instr: proceed ( flag -- flag )
\ ." proceed" cr
\ 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.
\ If this is in interactive mode, and the user doesn't want any more
\ solutions, don't print any.
interactive-mode flag-set? stop-search flag-set? and if exit endif
dup if
print-solutions
\ See if mor solutions are wanted.
interactive-mode flag-set? if
key [char] ; = if
1
else
stop-search on
0
endif
else
1
endif
( continue-flag ) if
\ ." trying alternatives after solution" cr
global-state cp-bp @ { alternative }
\ ." alternative is: " alternative . cr
\ ." fail is: " fail . cr
alternative ['] pl-fail <> if
." ;" cr
pop-choice-point
alternative pl-execute-xt
endif
endif
endif
;wam-instr
\ Put instructions
wam-instr: put_value ( vn ai -- )
\ Ai := Vn
swap @ swap !
;binary-wam-instr
\ For putting an EXISTING Y variable into an arg register.
wam-instr: put_existing_variable ( yn ai -- )
swap @ swap !
;binary-wam-instr
\ For creating a NEW unbound variable and putting it into two registers.
wam-instr: put_new_variable ( xn ai -- )
{ xn ai }
create-unbound dup xn ! ai !
;binary-wam-instr
wam-instr: put_constant ( n ai -- )
\ Ai := C
{ n ai }
n create-integer ai !
;binary-wam-instr
wam-instr: put_atom ( addr u ai -- )
\ make new atom from string, put in register ai
{ ai }
create-atom ai !
;ternary-wam-instr
wam-instr: put_nil ( ai -- )
\ Ai := nil
{ ai }
create-nil ai !
;unary-wam-instr
wam-instr: put_structure ( addr u arity ai -- )
create-functor !
;quaternary-wam-instr
wam-instr: put_list ( ai -- )
\ Ai := tag_list(H)
{ ai }
0 0 create-list dup ai !
list-args set-s
write global-mode !
;unary-wam-instr
\ Get instructions
wam-instr: get_variable ( vn ai -- )
\ Vn := Ai
{ vn ai }
ai @ vn !
;binary-wam-instr
wam-instr: get_value ( vn ai -- )
{ vn ai }
\ ." vn = " vn @ . cr
\ ." ai = " ai @ . cr
vn @ ai @ unify
vn @ dereference vn !
;binary-wam-instr
\ Meant for integers, C should be a number!
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
;binary-wam-instr
\ This is get_constant for atoms.
wam-instr: get_atom ( addr u ai -- )
{ addr u ai }
ai @ dereference dup ( atom-addr atom-addr -- )
tag case
unbound-tag of
addr u create-atom swap bind-reference
trail-var
endof
atom-tag of
atom-name addr u compare 0<> if
pl-fail
endif
endof
pl-fail
endcase
;ternary-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
( addr )
drop
endof
\ default: cannot unify with list
( addr )
drop
pl-fail
endcase
;unary-wam-instr
wam-instr: get_structure ( addr u arity ai -- )
{ addr u arity ai }
ai @ dereference dup
tag case
( struct-addr tag )
unbound-tag of
addr u arity create-functor
( var functor )
tuck swap
( functor functor var )
bind-reference trail-var
functor-args set-s
write enter-mode
endof
functor-tag of
( struct-addr )
dup functor-name addr u compare 0= if
\ correct name
( struct-addr )
functor-args set-s
read enter-mode
else
\ wrong name
( struct-addr )
drop
pl-fail
endif
endof
( stack state? )
pl-fail
endcase
;quaternary-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
drop
pl-fail
endcase
;unary-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
;unary-wam-instr
wam-instr: unify_variable ( vn -- )
{ vn }
mode write = if
create-unbound global-s @ !
endif
\ ." global-s @ @ = " global-s @ @ unparse cr
global-s @ @ vn !
global-s @ cell+ set-s
;unary-wam-instr
wam-instr: unify_value ( vn -- )
{ vn }
mode case
read of
\ ." global-s = " global-s . cr
\ ." global-s @ = " global-s @ . cr
\ ." global-s @ @ = " global-s @ @ . cr
\ ." global-s @ @ @ = " global-s @ @ @ . cr
\ ." global-s @ @ = " global-s @ @ unparse cr
global-s @ @ vn @
unify
vn @ dereference vn !
endof
write of
vn @ global-s @ !
endof
endcase
global-s @ cell+ set-s
;unary-wam-instr
\ This is for INTEGERS
wam-instr: unify_constant ( c -- )
{ c }
mode case
read of
global-s @ @ dereference dup
tag case
unbound-tag of
( var )
c create-integer
bind-reference trail-var
endof
integer-tag of
( integer )
integer-value c <> if
pl-fail
endif
endof
( some-other-thing )
drop
pl-fail
endcase
endof
write of
c create-integer global-s @ !
endof
endcase
global-s @ cell+ set-s
;unary-wam-instr
\ This is for ATOMS
wam-instr: unify_atom ( addr u -- )
{ addr u }
mode case
read of
global-s @ @ dereference dup
tag case
unbound-tag of
( var )
addr u create-atom
bind-reference trail-var
endof
atom-tag of
( atom )
atom-name addr u compare 0<> if
pl-fail
endif
endof
( some-other-thing )
drop pl-fail
endcase
write of
addr u create-atom global-s @ !
endof
endcase
global-s @ cell+ set-s
;unary-wam-instr
wam-instr: unify_nil ( -- )
mode case
read of
global-s @ @ create-nil unify
endof
write of
create-nil global-s @ !
endof
endcase
global-s @ cell+ set-s
;unary-wam-instr
wam-instr: wam-allocate ( -- )
global-state cp-e @ 42 cells +
global-state cp-e !
;wam-instr
wam-instr: wam-deallocate ( -- )
global-state cp-e @ 42 cells -
global-state cp-e !
;wam-instr
\ words to define:
\ try_me_else trust_me_else
wam-instr: try_me_else ( addr u -- )
\ cr ." *** try_me_else " 2dup type cr
evaluate ( xt )
\ ." xt = " dup . cr
set-alternative
push-choice-point
;binary-wam-instr
wam-instr: retry_me_else ( addr u -- )
evaluate ( xt )
set-alternative
;binary-wam-instr
\ wam-instr: trust_me_else ( xt -- )
\ ." trust_me_else" cr
\ 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
wam-instr: trust_me_else ( addr u -- )
\ ." trust_me_else new!" cr
evaluate ( xt )
set-alternative
\ push-choice-point
;binary-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 ;
: y1 global-state cp-e @ 0 cells + ;
: y2 global-state cp-e @ 1 cells + ;
: y3 global-state cp-e @ 2 cells + ;
: y4 global-state cp-e @ 3 cells + ;
: y5 global-state cp-e @ 4 cells + ;
: y6 global-state cp-e @ 5 cells + ;
: y7 global-state cp-e @ 6 cells + ;
: y8 global-state cp-e @ 7 cells + ;
: y9 global-state cp-e @ 8 cells + ;
: y10 global-state cp-e @ 9 cells + ;
: y11 global-state cp-e @ 10 cells + ;
: y12 global-state cp-e @ 11 cells + ;
: y13 global-state cp-e @ 12 cells + ;
: y14 global-state cp-e @ 13 cells + ;
: y15 global-state cp-e @ 14 cells + ;
: y16 global-state cp-e @ 15 cells + ;
: y17 global-state cp-e @ 16 cells + ;
: y18 global-state cp-e @ 17 cells + ;
: y19 global-state cp-e @ 18 cells + ;
: y20 global-state cp-e @ 19 cells + ;
: y21 global-state cp-e @ 20 cells + ;
: y22 global-state cp-e @ 21 cells + ;
: y23 global-state cp-e @ 22 cells + ;
: y24 global-state cp-e @ 23 cells + ;
: y25 global-state cp-e @ 24 cells + ;
: y26 global-state cp-e @ 25 cells + ;
: y27 global-state cp-e @ 26 cells + ;
: y28 global-state cp-e @ 27 cells + ;
: y29 global-state cp-e @ 28 cells + ;
: y30 global-state cp-e @ 29 cells + ;
: y31 global-state cp-e @ 30 cells + ;
: y32 global-state cp-e @ 31 cells + ;
: y33 global-state cp-e @ 32 cells + ;
: y34 global-state cp-e @ 33 cells + ;
: y35 global-state cp-e @ 34 cells + ;
: y36 global-state cp-e @ 35 cells + ;
: y37 global-state cp-e @ 36 cells + ;
: y38 global-state cp-e @ 37 cells + ;
: y39 global-state cp-e @ 38 cells + ;
: y40 global-state cp-e @ 39 cells + ;
: y41 global-state cp-e @ 40 cells + ;
: y42 global-state cp-e @ 41 cells + ;
\ 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
\ default: can't happen
abort
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
\ ." C1a" cr
C2a @ try_me_else \ concatenate(
C1 @ pl-execute ;
' C1a-def C1a !
: C1-def
\ ." C1" cr
a1 get_nil \ [],
a2 a3 get_value \ L,L
proceed \ ).
;
' C1-def C1 !
: C2a-def
\ ." C2a" cr
fail trust_me_else \ concatenate(
C2 @ pl-execute ;
' C2a-def C2a !
: C2-def
\ ." C2" cr
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 C2 !
:noname
C1a @ C1 @ C2 @ fail switch_on_term
; is concatenate
: prolog-shell ( xt -- )
\ Set "tail call" flag below the xt.
-1 swap
\ Be optimistic :-)
-1 prolog-success !
stop-search off
\ Call the goal itself.
pl-execute-xt
\ Report success or failure.
prolog-success @ if
." Yes!" cr
else
." No (further) solutions" cr
endif
\ Drop "tail call" flag.
drop ;
: 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
;
create global-ct1-l 0 ,
: concat-test-1-print-solutions
." L = " global-ct1-l @ unparse cr
;
: concat-test-1
\ concatenate([a], [b], L).
{ xt }
['] concat-test-1-print-solutions is print-solutions
s" a" create-atom create-nil create-list a1 !
s" b" create-atom create-nil create-list a2 !
create-unbound global-ct1-l !
global-ct1-l @ a3 !
." :- concatenate([a], [b], L)." cr
xt prolog-shell
;
create global-ct2-x 0 ,
: concat-test-2-print-solutions
." X = " global-ct2-x @ unparse cr
;
: concat-test-2
\ concatenate([a], [X], [a, b]).
{ xt }
['] concat-test-2-print-solutions is print-solutions
s" a" create-atom create-nil create-list a1 !
create-unbound global-ct2-x !
global-ct2-x @ create-nil create-list a2 !
s" b" create-atom create-nil create-list { tail }
s" a" create-atom tail create-list a3 !
create-unbound x4 !
." :- concatenate([a], [X], [a, b])." 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
;
: concat-test-3
\ concatenate([a,b,c], [D], [A|Rest]).
{ xt }
['] concat-test-3-print-solutions is print-solutions
s" a" create-atom { a }
s" b" create-atom { b }
s" c" create-atom { c }
a b c create-nil create-list create-list create-list { list1 }
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 }
list1 a1 !
list2 a2 !
list3 a3 !
." :- concatenate([a,b,c], [D], [A|Rest])." cr
xt prolog-shell
;
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
endif
global-ct4-b-var @ 0<> if
." B = " global-ct4-b-var @ unparse cr
endif
;
: concat-test-4
\ concatenate(A, B, [a,b]).
{ xt }
['] concat-test-4-print-solutions is print-solutions
create-unbound global-ct4-a-var !
create-unbound global-ct4-b-var !
s" a" create-atom s" b" create-atom create-nil
create-list create-list { l }
\ print-solutions
global-ct4-a-var @ a1 !
global-ct4-b-var @ a2 !
l a3 !
." :- concatenate(A, B, [a, b])." cr
xt prolog-shell
\ ." ;" cr
\ print-solutions
;
\ 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 }
cr
xt concat-test-1 cr
xt concat-test-2 cr
xt concat-test-3 cr
xt concat-test-4 cr
\ ." C1: " C1 @ . cr
\ ." C1a: " C1a @ . cr
\ ." C2: " C2 @ . cr
\ ." C2a: " C2a @ . cr
;
\ 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
: append-clause-1
s" ' 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
: append-clause-2
s" ' pl-fail" retry_me_else
a1 get_list
x4 unify_variable
a1 unify_variable
a3 get_list
x4 unify_value
a3 unify_variable
s" ' append" pl-execute ;
\ end code for clause 2 of append
: append append-clause-1 ;
\ ." append clause 1: " ' append-clause-1-def . cr
\ ." append clause 2: " ' append-clause-2-def . cr
\ ." append clause 3: " fail . cr
\ compare_terms +Term1, +Term2): Compare the two terms, bind Order to
\ one of the atoms 'less', 'greater', or 'equal'.
\ Comparison is almost according to the standard order of terms. Our order
\ is:
\ (unbound) variable < number < atom < nil < compound < cons
\ where
\ - variables are ordered by address
\ - numbers are ordered by value
\ - atoms are ordered alphabetically
\ - compounds are ordered by:
\ - functor arity
\ - functor name (alphabetically)
\ - arguments, left-to-right
s" less" create-atom constant less-atom
s" greater" create-atom constant greater-atom
s" equal" create-atom constant equal-atom
defer compare-unbound
defer compare-integer
defer compare-atom
defer compare-nil
defer compare-functor
defer compare-list
: compare-terms ( term1 term2 -- cmp-result )
dereference swap dereference swap
{ t1 t2 }
t1 tag t2 tag < if
-1
else t1 tag t2 tag > if
1
else
t1 t2
t1 tag case
unbound-tag of compare-unbound endof
integer-tag of compare-integer endof
atom-tag of compare-atom endof
nil-tag of compare-nil endof
functor-tag of compare-functor endof
list-tag of compare-list endof
endcase
endif endif
;
: number-compare ( n1 n2 -- cmp-result )
2dup < if -1 else
2dup > if 1 else
0
endif endif
( n1 n2 result )
nip nip
;
:noname ( unbound1 unbound2 -- cmp-result )
number-compare
; is compare-unbound
:noname ( integer1 integer2 -- cmp-result )
integer-value swap integer-value swap
number-compare
; is compare-integer
:noname ( atom1 atom2 -- cmp-result )
atom-name rot atom-name 2swap
compare \ yippie, this word is predefined
; is compare-atom
:noname ( nil1 nil2 -- cmp-result )
\ nil is always equal to nil
drop drop 0
; is compare-nil
: compare-args ( args1 args2 n -- cmp-result )
0 \ so far, the arg lists are equal; top-of-stack will keep track of
\ this status
begin
( args1 args2 counter cmp-result )
over 0 > over 0 = and while
( args1 args2 counter cmp-result )
drop \ result is 0, we don't need to hang on to it
1- { next-counter }
( args1 args2 )
over @ over @ compare-terms { result }
\ setup stack for next iteration
cell+ swap cell+ swap
next-counter
result
repeat
( args1 args2 0 result )
{ final-result }
drop drop drop
final-result
;
:noname ( compound1 compound2 -- cmp-result )
2dup functor-arity swap functor-arity swap ( c1 c2 a1 a2 )
number-compare dup 0 = if
( c1 c2 0 ) drop
functor-name rot functor-name 2swap
compare dup 0 = if
( c1 c2 0 ) drop
dup functor-arity
( c1 c2 n )
rot functor-args
rot functor-args
rot
( args1 args2 n )
>r 2dup r> compare-args
endif
endif
( c1 c2 cmp-result )
nip nip
; is compare-functor
: compare_terms ( flag -- )
wam-instr-prologue
." compare_terms("
a1 @ unparse ." , "
a2 @ unparse ." , "
a3 @ unparse ." )"
a2 @ a3 @ compare-terms
case
-1 of less-atom endof
0 of equal-atom endof
1 of greater-atom endof
endcase a1 get_constant
." -> success: " prolog-success @ . cr
\ ." compare_terms("
\ a1 @ unparse ." , "
\ a2 @ unparse ." , "
\ a3 @ unparse ." )" cr
dup -1 = if
print-solutions
endif
wam-instr-epilogue
;
: compare_terms/3-clause-1 compare_terms ;