\ compiler.fs -- a simplified Prolog -> Warren Abstract Machine (WAM) compiler
\
\ Copyright (C) December 2008 and January 2009
\ Adrian Prantl and Gergö Barany
\
\   This program is free software: you can redistribute it and/or modify
\   it under the terms of the GNU General Public License as published by
\   the Free Software Foundation, either version 3 of the License, or
\   (at your option) any later version.
\
\   This program is distributed in the hope that it will be useful,
\   but WITHOUT ANY WARRANTY; without even the implied warranty of
\   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
\   GNU General Public License for more details.
\
\   You should have received a copy of the GNU General Public License
\   along with this program.  If not, see <http://www.gnu.org/licenses/>
\
\ Features:
\ 
\ This file contains a recursive-descent parser for a subset of Prolog
\ that generates WAM instructions on-the-fly, using a lookahead of 1 goal.
\ It copes with facts, clauses and queries. Supported primitives are
\ atoms, lists, named and anonymous variables, the :- operator and structures.
\ Definitely NOT supported are integers, DCGs and infix operators apart from
\ the ":-".
\ The generated code tries to follow the one described in [Warren 1983] as
\ closely as possible. The most significant difference is that the machine
\ code ist output in postfix notation. This makes it possible to directly
\ evaluate the generated code as forth words. The virtual machine
\ implementation can be found in the file 'wam.fs'.
\ This file also contains a toplevel shell that allows for readline-like
\ command editing.
\
\ Things to try out:
\
\ Start the prolog shell with 
\   $ gforth wam.fs compiler.fs -e queries
\   ...
\   Enter queries, one per line; empty line when you're done.
\   ?- concatenate(A,B,[a,b]).    
\   B = [a, b]
\   A = []
\   ;
\   B = [b]
\   A = [a]
\   ;
\   B = []
\   A = [a, b]
\   ;
\   No (further) solutions
\   ?-
\   
\   Type ';' to ask the system for more solutions.
\
\
\ Literature:
\
\   [Warren 1983] David H. D. Warren. "An abstract Prolog instruction set".
\      Technical Note 309, SRI International, Menlo Park, CA, October 1983.



Create VAR-Dict table , \  Create a case-sensitive wordlist
Create X 0 , \ FIXME: use a struct instead
Create Y 0 ,
Create A 0 ,
Create cur-mode 0 ,
Create compile-buf-start 4096 chars allot
Create compile-buf compile-buf-start ,
Create last-clause 256 chars allot
Create last-clause-u 0 ,
Create last-nargs 0 ,
Create clause# 1 ,
Create tailcall-flag 0 ,
Create tracing -1 ,

defer term
defer structure
defer cons
defer cons,
defer bind-new-var

: not ( b b ) invert ;
: nand ( b b ) invert and ;

: set? ( u bit -- b ) tuck and = ; \ check whether bit is set

: 3drop 2drop drop ;
: 3dup { a b c } a b c a b c ;

: inc ( addr -- u ) dup @ dup 1+ ( addr old new ) rot ! ;
: dec ( addr -- ) dup @ 1- ( addr new ) swap ! ;
: newA ( -- u ) A inc ;
: newX ( -- u ) X inc ;
: lastX ( -- u ) X @ 1- ;

: x-mode 1 ; \ Compile into X-regs
: a-mode 2 ; \ Compile into A-regs
: c-mode 4 ; \ Compile against A-regs (clause mode)
: FutureArg 256 ; \ Register assigned by the regalloc prepass
: DirectArg 512 ; \ Register was assigned in the head

: head? ( -- b ) cur-mode @ c-mode set? ;
: query? ( -- b ) s" (toplevel)" last-clause last-clause-u @ compare 0 = ;
: tailcall? ( -- b ) tailcall-flag @ ;

\  Compilation buffer handling

: uc->c+str { u c -- "cuuu(decimal)" } \ works only for u in 0-99
    noname create here { addr } addr
    3 chars allot
    c over ! 1 chars +
    u 10 / dup 0 > if [Char] 0 + over ! 1 chars + else drop endif
    u 10 mod          [Char] 0 + over ! 1 chars +
    addr - addr swap    
;

: cb-next ( -- ) compile-buf @ 1 chars + compile-buf ! ;
: push-ws ( -- ) ( ."  " ) 32 compile-buf @ ! cb-next ; 
: push-cr ( -- ) (    cr ) 10 compile-buf @ ! cb-next ;
: push-xt, ( addr u -- ) \  push the xt^H^H the string on the compile-buf
     \ 2dup type
     \ sadly doesn't work...
     \ nextname ' ( xt )
    { u } compile-buf @ u cmove
    compile-buf @ u chars + compile-buf !
;

: push-xt ( addr u -- ) \  push the xt^H^H the string on the compile-buf
    push-xt,
    push-ws
     \ debug..
     \ compile-buf @ u chars - u type cr
;
: push-xt; ( addr u -- ) push-xt, push-cr ;

: yreg ( u -- ) [Char] Y uc->c+str push-xt ;
: xreg ( u -- ) [Char] X uc->c+str push-xt ;
: areg ( u -- ) [Char] A uc->c+str push-xt ;
: push-functor { addrF uF nargs -- } \ build and push 'f/3'
    addrF uF push-xt, nargs [Char] / uc->c+str push-xt,
;

: push-comment; ( addr u -- ) s"  (" push-xt push-xt s" )" push-xt; ;

: push-clause-name ( addr u nargs )
    push-functor s" -clause" push-xt,
    clause# @ [Char] - uc->c+str push-xt,
;

: end-last-clause
    last-clause-u @ 0 > if \  let the last one fail
	s" : " push-xt,
	last-clause last-clause-u @ last-nargs @ push-clause-name
	s"  pl-fail ;" push-xt;
    endif
;

: clause-header { addr u nargs }
    addr u last-clause last-clause-u @ compare 0 <> if
\ 	cr
\ 	addr u type cr
\ 	last-clause last-clause-u @ type cr
\ 	cr
	end-last-clause
	nargs last-nargs !
	\ inc
	1 clause# !
	addr last-clause u cmove
	u last-clause-u !
    endif
    clause# inc drop
    \ s" Create " push-xt, addr u nargs push-clause-name push-cr
    clause# dec
    s" : " push-xt, addr u nargs push-clause-name s" " push-xt;

    ( debugging )
    s\" tracing flag-set? if .\" <entering " push-xt, addr u nargs push-clause-name
    s\" >\" cr endif" push-xt;
    
    clause# inc drop

    ( Backtracking )
    s" (toplevel)" addr u cr ( 2dup type cr cr ) compare 0 =
    if	s\" s\" ' pl-fail\" try_me_else" push-xt;
    else s\" s\" '" push-xt addr u nargs push-clause-name
	s\" \" try_me_else" push-xt; endif

    ( Trail stack management )
    query? not if s" wam-allocate" push-xt; endif
;
	
\ ----------------------------------------------------------------------
\ SCANNING
\ ----------------------------------------------------------------------

: between ( c c1 c2 -- b )
    rot tuck ( c1 c c2 c ) >=
    -rot ( b c1 c ) <=
    and
;

: peek ( addr u -- addr u c )
    \ dup invert throw \ assert u>0
    over c@
    \ dup emit .\"  peeked\n"
;

: peek-next ( addr u -- addr u c )
    over 1+ c@
;

: expect { addr u c -- addr u }
    u 0 <= throw
    addr c@ c <> throw
    addr chars 1+ u 1-
;

: alpha?  { c -- b }
    c [Char] a [Char] z between
    c [Char] . = or
    c [Char] _ = or
;
: vALPHA? ( c -- b ) [Char] A [Char] Z between ;
: Num?    ( c -- b ) [Char] 0 [Char] 9 between ;
: (? ( c -- b ) [Char] ( = ;
: )? ( c -- b ) [Char] ) = ;
: [? ( c -- b ) [Char] [ = ;
: ]? ( c -- b ) [Char] ] = ;
: |? ( c -- b ) [Char] | = ;
: ,? ( c -- b ) [Char] , = ;
: .? ( c -- b ) [Char] . = ;
: _? ( c -- b ) [Char] _ = ;
: ws? 32 = ;

: AlphaNum? ( c -- b )
    dup ( c c ) alpha? ( c b ) swap ( b c )
    dup ( b c c ) vALPHA? ( b c b ) swap ( b b c )
    Num? ( b b c )
    or or
;

: Arrow? ( addr u -- addr u b )
    peek      [Char] : = >r
    peek-next [Char] - = r>
    and
;

: Nil? ( addr u -- addr u b )
    peek      [Char] [ = >r
    peek-next [Char] ] = r>
    and
;

: next-char ( addr u -- addr u )
    swap chars 1+ swap 1-
;

: prev-char ( addr u -- addr u )
    swap chars 1- swap 1+
;

: skip-ws ( addr u -- addr u )
    dup 0 <> if begin
	dup 0 <> >r peek ws? r> and while
	    next-char
    repeat endif
;

: scan-tok  ( addr u -- addrRest u addrTok u )
    2dup dup 1+
    1 +do ( addr u addr u )
	drop i peek ( addr u addr i c )
	AlphaNum? not if 1- leave endif
	swap chars 1+ swap
    loop { addrTok u addrRest tok_length }
    \ ." TOK: " addrTok tok_length type cr
    addrRest u tok_length - addrTok tok_length
;

: until) ( addr u -- addr u ) \ skip til matching ')
    dup 0= throw \ eof
    0 begin ( addr u cnt )
	>r \ 2dup type cr
	peek (? if r> 1+ >r else
	peek )? if r> 1- >r
	endif endif
        next-char r@ r> 0 =
    until drop
;

: until] ( addr u -- addr u ) \ skip til matching ']
    dup 0= throw \ eof
    0 begin ( addr u cnt )
	>r \ 2dup type cr
	peek [? if r> 1+ >r else
	peek ]? if r> 1- >r
	endif endif
        next-char r@ r> 0 =
    until drop
;

: IfxExp? ( addr u -- addr u b )
    2dup scan-tok 2drop
    peek (? if until) endif
    skip-ws
    Arrow?
    -rot 2drop
;


\ Prepass: count #arguments, allocate registers for variables.

: regalloc ( i addr u -- )
    peek vAlpha? if
	rot FutureArg or -rot
	bind-new-var else
	3drop endif
;

: num-args-regalloc ( addr u -- addr u nargs )
    \ count the number of args of a functor
    2dup next-char
    1 >r begin 
	skip-ws scan-tok 2drop
	peek (? if until) endif	skip-ws
	peek [? if until] endif	skip-ws 
	peek ,? if r> 1+ >r next-char skip-ws endif
    peek )? until
    
    \ register allocation for VAR-Dict
    next-char skip-ws
    dup 0 > if \ eof?    
	Arrow? dup if >r next-char r> endif >r peek ,? r> or if
	    next-char skip-ws scan-tok 2drop
	    peek (? if \ functor
		next-char
		1 >r begin 
		    skip-ws scan-tok r@ -rot regalloc
		    peek (? if until) endif	skip-ws
		    peek [? if until] endif	skip-ws 
		    peek ,? if r> 1+ >r next-char skip-ws endif
		peek )? until
		r> drop
	    endif
	endif	
    endif
    2drop r>
;

\ \\\\\\\\\\\\\\\

: drop3rd rot drop ;

\ collect all arguments of a functor
: args { mode addr u -- ... mode count addr u }
    0 >r addr u prev-char
    begin
	r> 1+ >r
	mode r@ 8 lshift or -rot
	next-char term drop3rd peek ,? not
    until
    mode r> 2swap 
;

: paren ( addr u xt -- addr u )
    >r next-char r> execute skip-ws peek )? not throw next-char
;

: lowermode drop3rd x-mode -rot ;

: nil { mode addr u -- addr u mode addr u } s" []" mode addr u ;

\ cons for the [a,b,c] syntax
\ the difference is that ']' generates an implicit '|[]'
: cons,' { mode addr u  -- ... mode addr u }
    mode addr u
    next-char 
    peek ]? if next-char nil
    else
	\ Head
	lowermode
	term skip-ws
	\ Tail
	peek ]? if next-char nil else \ end of list
        peek ,? if cons, else
	    cr ." SYNTAX ERROR: expected ']' or ',' before " type cr bye
	endif endif
	2>r drop mode 2 s" ." structure mode 2r> 
     endif
;
' cons,' is cons,

: cons' { mode addr u  -- ... mode addr u }
    mode addr u
    next-char 
    peek ]? if next-char nil
    else
	\ Head
	lowermode
	term skip-ws
	\ Tail
	peek ]? if next-char nil else \ end of list
        peek ,? if cons, else
	peek |? if next-char term peek ]? not throw next-char else
	    \ if next-char Nil? if next-char else prev-char endif cons else
	    cr ." SYNTAX ERROR: expected ']', '|' or ',' before " type cr bye
	endif endif endif
	2>r drop mode 2 s" ." structure mode 2r> 
     endif
;
' cons' is cons

\ ----------------------------------------------------------------------
\ COMPILATION
\ ----------------------------------------------------------------------

\ data types
: atom? peek alpha? ;
: var? peek vALPHA? ;
: nil? ( addr u -- addr u b )
    dup 1 > if
	peek [? -rot peek-next ]? and else
	0
    endif
;
: reg? over 0 = ;
: void? over 1 = ;

\ register allocator
: find-var ( addr u -- xt? b )
    \ 2dup ." searching for " type cr
    VAR-Dict search-wordlist
;
: bind-new-var' ( val addr u -- )
    2dup find-var if \ update
	nip nip execute !
    else  \ bind new
	get-current { old }
	VAR-Dict set-current
	\ ." --> binding " 2dup type ."  to " rot dup . -rot cr
	nextname create , \  alloc and initialize
	old set-current
    endif
;
' bind-new-var' is bind-new-var

: ->ar ( u -- u ) FutureArg nand ;

: unify-temporary ( addr u )
    2dup
    newX -rot bind-new-var
    lastX Yreg s" unify_variable" push-xt
    push-comment;
;

: future-arg? ( u -- u b ) dup FutureArg set? ;
: direct-arg? ( u -- u b ) dup DirectArg set? ;

: compile-var-struct { i addr u }
    addr u find-var if  \ already alloc'd
	execute @
 	future-arg? if \ needed in future Ax
	    dup ->ar i < if   \ Ax is not live any more
		\ use the target Ax register directly
		dup ->ar Areg s" unify_variable" push-xt
		addr u push-comment;
		\ mark as directly alloc'd
		DirectArg or addr u bind-new-var
		\ s" direct " push-comment;
	    else drop addr u unify-temporary endif
	else ->ar Yreg s" unify_value" push-xt; endif
    else \   create new
	addr u unify-temporary
    endif
;

: getput ( -- )   head? if s" get_" else s" put_"   endif push-xt, ;
: getunify ( -- ) head? if s" get_" else s" unify_" endif push-xt, ;

: getput-variable ( -- )
    head? if s" get_variable" else s" put_new_variable" endif push-xt, ;
: getput-value ( -- ) getput s" value" push-xt ;
: getput-list ( -- )  getput s" list" push-xt ;
: getput-atom ( -- )  getput s" atom" push-xt ;
: getput-nil  ( -- )  getput s" nil"  push-xt ;
: getput-structure ( -- ) getput s" structure" push-xt ;

: getunify-value ( -- ) getunify s" value" push-xt ;
: getunify-nil   ( -- ) getunify s" nil"   push-xt ;
: getunify-void  ( -- )     s" 1 unify_void ( _ )" push-xt ;

: copy-temporary { i addr u -- }
    query? if  \  head?
	newX addr u bind-new-var
        lastX yreg i areg getput-variable
        addr u lastX register-query-var
	addr u push-comment;
    else
	newX addr u bind-new-var
	lastX yreg i areg getput-variable
	addr u push-comment;
    endif
;

: compile-var-arg { i addr u -- }  \	addr u push-comment;
    addr u find-var if  \  already alloc'd
	execute @
	direct-arg? if
	    \ skip (already unified)
	    ->ar addr u bind-new-var
	else
	    future-arg? head? nand if
		drop \ ignore
		i addr u copy-temporary
	    else
		dup ->ar i = if
		    \ skip (identical) copy and mark as directly alloc'd
		    ->ar DirectArg or addr u bind-new-var
		    \ s" direct " push-comment;
		else
		    future-arg? if
			->ar addr u copy-temporary
		    else Yreg i Areg getput-value endif
		    addr u push-comment;
		endif
	    endif
	endif
    else  \  create/use new temporary
	i addr u copy-temporary
    endif
;

: compile-structval ( i addr u -- ) 
    reg?  if Xreg getunify-value 2drop push-cr else
    void? if getunify-void 3drop push-cr else
    var?  if compile-var-struct else
    nil?  if 3drop getunify-nil push-cr else
    -1 throw
    endif endif endif endif
;

: compile-arg ( i addr u -- )
    \ 3dup ."                      \ compiling " type ." , #" . cr
    reg?  if 3drop ( ." set_value A" A @ . cr ) else
    void? if 3drop else
    atom? if throw else \ 0 -rot structure
    var?  if compile-var-arg else
    nil?  if 2drop Areg getput-nil push-cr else
    -1 throw
    endif endif endif endif endif
;

: 2roll ( ... n -- ... ) \ roll n pairs of arguments on the stack
    dup + 1- dup >r roll r> roll
;

: for-each-arg ( compilation: xt -- ; run-time: addr u ... nargs  -- )
    { xt }
    1 postpone literal postpone A postpone ! \  FIXME do something better
    0 postpone literal postpone swap postpone u-do
	postpone i postpone 2roll \ reverse argument list
        postpone newA postpone -rot \ narg
        xt compile,
    1 postpone literal postpone -loop
;

: isList? { nargs addr u }
     nargs 2 =
         u 1 =
    addr c@ [Char] . = and and
;

\ Argument order:
\ head? -> outer .. inner
\ query,clause? -> inner .. outer

: quote-atom ( addr u -- )
    s\" s\"" push-xt push-xt, s\" \"" push-xt,
;

: structure' ( ... ) { mode nargs addrF uF -- 0 u }
    mode cur-mode !

    nargs 0 = if addrF uF quote-atom s" " push-xt endif
    
    mode x-mode set? if
	newX Xreg
    else
	mode 8 rshift Areg
    endif

    nargs 0 = if getput-atom else
	nargs addrF uF isList? if getput-list else
        addrF uF quote-atom nargs 32 uc->c+str push-xt getput-structure endif
    endif
    push-cr
    nargs [ ' compile-structval for-each-arg ]
    0 lastX
;
' structure' is structure

: head ( ... ) { mode nargs addrF uF }
    mode cur-mode !
    nargs [ ' compile-arg for-each-arg ]
;

: push-call ( addrF uF nargs -- )
    tailcall? if
	query? not if s" wam-deallocate" push-xt; endif
	s\" s\" '" push-xt
	push-functor s\" -clause-1\" pl-execute" push-xt;
    else
	s\" s\" '" push-xt
	push-functor s\" -clause-1\" pl-call" push-xt;
    endif ;

: query ( ... ) { mode nargs addrF uF }
    mode nargs addrF uF head
    addrF uF nargs push-call
;

: goal ( ... ) { mode nargs addrF uF }
    mode cur-mode !
    nargs [ ' compile-arg for-each-arg ]
    addrF uF nargs push-call
;

: functor|atom ( mode addr u -- ... mode addr u )
    scan-tok { mode addrR uR addrF uF }
    addrR uR
    peek (? if \ functor
	x-mode -rot
	['] args paren ( args... ) { _mode nargs addrR1 uR1 }
	mode nargs addrF uF structure \ push reg
	mode addrR1 uR1
    else \ atom
	2drop
	mode 0 addrF uF structure \ push reg
	mode addrR uR
    endif
;

: void { mode addr u -- 1 u mode addr u }
    1 u mode addr u
    next-char
;

: var ( mode addr u -- addr u mode addr u )
    scan-tok { mode addr u addrV uV }
    \ 2dup ." set_variable " type cr
    addrV uV mode addr u \ push VAR
;

: term' ( mode addr u -- ... mode addr u )
    skip-ws
    peek _?                      if void else
    peek dup alpha? swap Num? or if functor|atom else
    var?                         if var else
    peek (?                      if ['] term paren else
    peek [?                      if cons else
    throw
    endif endif endif endif endif
    \ IfxOp?        if operator endif
    \ throw \ "if u != 0" throw
;

' term' is term


: init ( nargs -- )
    2 + X !
    0 A !
;

: freshdict
    \ set the marker
    get-current { old }
    VAR-Dict set-current
    s" new-dict" nextname marker
    old set-current
;

: cleardict
    \ clear VAR-Dict dictionary
    get-current { old }
    VAR-Dict set-current
    s" new-dict" VAR-Dict search-wordlist if execute endif
    old set-current
;

: set-tailcall-flag ( addr u -- ) 2dup skip-ws peek .? tailcall-flag ! 2drop ;

: compile-query ( addr u -- )
    s" (toplevel)" 0 clause-header
    1 clause# !

    clear-query-vars
    
    a-mode cur-mode !
    skip-ws
    scan-tok { addrF uF }
    peek (? if \ functor
	num-args-regalloc init
	cur-mode @ -rot
	['] args paren

	set-tailcall-flag { addrR uR }
	
	addrF uF query
	addrR uR
	\ push X
    else \ atom
	0 init
	cur-mode @ 0 addrF uF query
	\ push ATOM
    endif
    s" ;" push-xt;
;

: compile-head ( addr u -- addr u )
    c-mode cur-mode !
    skip-ws
    scan-tok { addrF uF }
    peek (? if \ functor
	num-args-regalloc dup { nargs } init
	addrF uF nargs clause-header
	cur-mode @ -rot
	['] args paren { addrR uR }
	addrF uF head
	addrR uR
	\ push X
    else \ atom
	0 init
	addrF uF 0 clause-header
	cur-mode @ 0 addrF uF head	\ push ATOM
	compile-arg
    endif
;

: compile-body ( addr u -- addr u )
    a-mode cur-mode !
    skip-ws
    scan-tok { addrF uF }
    peek (? if \ functor
	cur-mode @ -rot
	['] args paren \  process args

	set-tailcall-flag { addrR uR }
	
	addrF uF goal \  compile..
	addrR uR
	\ push X
    else \ atom
	0 init
	cur-mode @ 0 addrF uF query
	\ push ATOM
    endif
;

: compile-clause ( addr u -- )
    freshdict
    skip-ws
    Arrow? if  \  query
	next-char next-char
	compile-query
    else
	IfxExp? if  \  clause
	    compile-head
	    skip-ws Arrow? not throw next-char next-char
	    begin 
		skip-ws compile-body
		skip-ws peek ,? while next-char
	    repeat
	else  \  fact
	    compile-head
	    query? not if s" wam-deallocate" push-xt; endif
	    s" proceed" push-xt;
	endif
	[Char] . expect 
	s" ; " push-xt;
	clause# dec
	\ s" '" push-xt 	last-clause last-clause-u @ last-nargs @ push-clause-name s"  . cr" push-xt;
	clause# inc drop
	type
    endif
    cleardict
;

: eval
    compile-buf-start compile-buf @ over -
    ( Debug print )
  \ 2dup type
    ( let gforth compile the clause )
    evaluate
    ( run, if query )
    query? if
    cr \ so we are not on the same line as the "redefined" messages
	s" ' (toplevel)/0-clause-1 prolog-shell" evaluate
    endif
;    

: compile ( addr u -- )
    ( echo )
    2dup cr type cr
    ( Clear buffer )
    compile-buf-start compile-buf !
    ( Compile )
    compile-clause
    ( Debug print )
    compile-buf-start compile-buf @ over - type

    clearstack
;

\ ----------------------------------------------------------------------
\ SHELL
\ ----------------------------------------------------------------------

256 constant max-line
create clause-input-buf max-line chars allot

: clauses ( -- )
    cr ." Enter clauses, one per line; empty line when you're done." cr
    begin
        ." > "
        clause-input-buf max-line accept
        ( input-len )
        dup 0<> while
            clause-input-buf swap
            compile
            eval
    repeat
    drop
    ;

: queries ( -- )
    cr ." Enter queries, one per line; empty line when you're done." cr
    tracing off
    begin
        ." ?- "
        clause-input-buf max-line accept
        ( input-len )
        dup 0<> while
            interactive-mode on
            clause-input-buf swap
            compile-query
            eval
    repeat
    drop
    interactive-mode off
    tracing on
    ;

\ concatenate([], L, L).
\ concatenate([X|L1], L2, [X|L3]) :- concatenate(L1, L2, L3).
\
\ concatenate/3: switch_on_term C1a, C1, C2, fail
\
\ C1a: try_me_else C2a
\ C1:  get_nil A1
\      get_value A2, A3
\      proceed
\
\ C2a: trust_me_else fail
\ C2:  get_list A1
\      unify_variable X4
\      unify_variable A1
\      get_list A3
\      unify_variable X4
\      unify_variable A3
\      execute concatenate/3


\ ----------------------------------------------------------------------
\ TESTS
\ ----------------------------------------------------------------------

s" :- test" scan-tok clearstack
s"  :- atom1" compile
s" :- f(a,b)" compile
s" :- f(f(a,b),g(c,h(d,e)))" compile
s" :- p(Z,h(Z,W),f(W))" compile
s" :- f([])" compile
s" :- f([X])" compile
s" :- f(.(a,.(b,.(c,[]))))" compile
s" :- f([a,b,c])" compile
s" :- do(parse(s(np,vp),[birds,fly,[]]))" compile
s" :- f([X|[]])" compile
s" :- f([X|Xs])" compile

s" missing_feature(garbage_collection)." compile eval
s" missing_feature(bug_fixes)." compile eval


s" concatenate([],L,L)." compile eval
s" concatenate([X|L1],L2,[X|L3]) :- concatenate(L1,L2,L3)." compile eval
s" :- concatenate([],[],[])." compile eval 
s" :- concatenate([],X,X)." compile eval

s" :- concatenate([a,b],[c],X)." compile eval 
s" :- concatenate(A,B,[a,b])." compile eval

s" split([], L, [], [])." compile eval
s" split([X|Xs], X, [X|Ls], Gs) :- split(Xs, X, Ls, Gs)." compile eval
s" split([L|Xs], X, [L|Ls], Gs) :- compare_terms(less, L, X), split(Xs, X, Ls, Gs)." compile eval
s" split([G|Xs], X, Ls, [G|Gs]) :- compare_terms(greater, G, X), split(Xs, X, Ls, Gs)." compile eval
s" :- split([], a, A, B)." compile eval

s" qsort([],R,R)." compile eval
s" qsort([X|L],R0,R) :- split(L,X,L1,L2), qsort(L1,R0,[X|R1]), qsort(L2,R1,R)." compile eval

s" :- qsort([a], [], R)." compile eval
s" :- qsort([], [a,b,c], R)." compile eval
s" :- qsort([a,b,c], [], R)." compile eval
s" :- qsort([b,a,c], [], R)." compile eval
s" :- compare_terms(Y,a,b)." compile eval

s" member(X,[X|_])." compile eval
s" member(X,[_|L]) :- member(X,L)." compile eval
s" :- member(X,[a,b,c])." compile eval