\ 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 ;