[Evaluate (still in progress...)
Adrian Prantl <adrian@complang.tuwien.ac.at>**20090125172247] {
hunk ./compiler.fs 8
+Create last-clause 256 chars allot
+Create last-clause-u 0 ,
+Create last-nargs 0 ,
+Create clause# 1 ,
hunk ./compiler.fs 19
-: newA ( -- u ) A @ dup 1+ A ! ;
-: newX ( -- u ) X @ dup 1+ X ! ;
+: 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 ;
hunk ./compiler.fs 38
-: strcpy ( addr u 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 )
-    ;
+\  Compilation buffer handling
hunk ./compiler.fs 49
-\  Compilation buffer handling
-
hunk ./compiler.fs 50
-: push-ws ( -- ) ."  " 32 compile-buf @ ! cb-next ; 
-: push-cr ( -- )    cr 10 compile-buf @ ! cb-next ;
+: push-ws ( -- ) ( ."  " ) 32 compile-buf @ ! cb-next ; 
+: push-cr ( -- ) (    cr ) 10 compile-buf @ ! cb-next ;
hunk ./compiler.fs 53
-    2dup type
+     \ 2dup type
hunk ./compiler.fs 71
-: functor { addrF uF nargs -- } \ build and push 'f/3'
-    addrF uF push-xt, nargs [Char] / 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,
hunk ./compiler.fs 75
-: set? ( u bit -- b ) tuck and = ; \ check whether bit is set
hunk ./compiler.fs 76
-: 3drop 2drop drop ;
-: 3dup { a b c } a b c a b c ;
+: push-clause-name ( addr u nargs )
+    push-functor s" -clause" push-xt,
+    clause# @ [Char] - uc->c+str push-xt,
+;
hunk ./compiler.fs 81
+: 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" -def fail ;" push-xt;
+    endif
+;
+
+: clause-header { addr u nargs }
+    addr u last-clause last-clause-u @ compare 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" -def" push-xt;
+    clause# inc drop
+    addr u nargs push-clause-name s"  @ try_me_else ~~" push-xt;
+;
+	
hunk ./compiler.fs 113
-: not ( b b ) invert ;
-: nand ( b b ) invert and ;
-
hunk ./compiler.fs 390
-    newX addr u bind-new-var
-    lastX yreg i areg getput-variable push-cr
+    head? if  \  FIXME: WHY
+	newX addr u bind-new-var
+	lastX yreg i areg getput-variable push-cr
+    endif
hunk ./compiler.fs 459
-    else addrF uF nargs functor getput-structure endif
+    else addrF uF nargs push-functor getput-structure endif
hunk ./compiler.fs 473
-    addrF uF nargs functor s" call" push-xt;
+    s" '" push-xt
+    addrF uF nargs push-functor s" -clause-1-def pl-execute" push-xt;
hunk ./compiler.fs 480
-    addrF uF nargs functor s" call" push-xt;
+    s" '" push-xt
+    addrF uF nargs push-functor s" -clause-1-def pl-execute" push-xt;
hunk ./compiler.fs 525
+: freshdict
+    \ set the marker
+    get-current { old }
+    VAR-Dict set-current
+    s" new-dict" nextname marker
+    old set-current
+;
+
hunk ./compiler.fs 537
-    s" new-dict" 2dup VAR-Dict search-wordlist if execute endif
-    nextname marker
+    s" new-dict" VAR-Dict search-wordlist if execute endif
hunk ./compiler.fs 542
+    s" (toplevel)" 0 clause-header
+    1 clause# !
hunk ./compiler.fs 548
-	cleardict
hunk ./compiler.fs 559
+    s" ; " push-xt;
+    end-last-clause
hunk ./compiler.fs 566
-    scan-tok ." Cx Cy fail switch_on_term \ " 2dup type cr { addrF uF }
-    s" Cy Cz try_me_else" push-xt;
+    scan-tok { addrF uF }
hunk ./compiler.fs 568
-	cleardict
-	num-args-regalloc init
+	num-args-regalloc dup { nargs } init
+	addrF uF nargs clause-header
hunk ./compiler.fs 577
+	addrF uF 0 clause-header
hunk ./compiler.fs 601
+    freshdict
hunk ./compiler.fs 618
+	s" ; " push-xt;
hunk ./compiler.fs 621
+    cleardict
hunk ./compiler.fs 627
-    2dup type cr
+    2dup type
hunk ./compiler.fs 630
+    ( run, if query )
+    s" (toplevel)/0" last-clause last-clause-u @ compare if
+	s" ' (toplevel)/0-clause-1-def prolog-shell" evaluate
+    endif
hunk ./compiler.fs 690
-s" concatenate([X|L1],L2,[X|L3]) :- concatenate(L1,L2,L3)." test-compile
+s" concatenate([X|L1],L2,[X|L3]) :- concatenate(L1,L2,L3)." test-compile run-clause
+s" :- concatenate([],[],[])." test-compile run-clause
hunk ./compiler.fs 693
-s" qsort([],R,R)." test-compile
-s" qsort([X|L],R0,R) :- split(L,X,L1,L2), qsort(L1,R0,[X|R1]), qsort(L2,R1,R)." test-compile
+\ s" qsort([],R,R)." test-compile
+\ s" qsort([X|L],R0,R) :- split(L,X,L1,L2), qsort(L1,R0,[X|R1]), qsort(L2,R1,R)." test-compile
}