[Improved register allocator
Adrian Prantl <adrian@complang.tuwien.ac.at>**20090120160543] {
hunk ./compiler.fs 11
+defer bind-new-var
hunk ./compiler.fs 20
+: FutureArg 256 ; \ Register assigned by the regalloc prepass
hunk ./compiler.fs 24
+: 3drop 2drop drop ;
+
hunk ./compiler.fs 31
+: nand ( b b ) invert and ;
hunk ./compiler.fs 122
-: until] ( addr u -- addr u ) \ skip til matching ')
+: until] ( addr u -- addr u ) \ skip til matching ']
hunk ./compiler.fs 141
-: num-args ( addr u -- addr u nargs ) \ count the number of args of a functor
+
+\ 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
hunk ./compiler.fs 160
+    
+    \ register allocation for VARS
+    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
hunk ./compiler.fs 263
-: bind-new-var ( val addr u -- )
+: bind-new-var' ( val addr u -- )
hunk ./compiler.fs 266
-    \ ." binding " 2dup type ."  to " 2over . drop cr
+    \ ." --> binding " 2dup type ."  to " rot dup . -rot cr
hunk ./compiler.fs 270
+' bind-new-var' is bind-new-var
hunk ./compiler.fs 275
-    addr u find-var if \  already alloc'd
-	execute @ ." Y" . ." unify_value" cr
+    addr u find-var if  \ already alloc'd
+	execute @
+	FutureArg dup set? if
+	    \ store real arg
+	    FutureArg nand dup addr u bind-new-var
+	    ." A" . ." unify_variable" cr
+	else ." Y" . ." unify_value" cr endif
hunk ./compiler.fs 292
-	execute @
-	dup i = if drop \ skip indent. copy
-	else ." Y" . ." A" i . getput ." _value" cr endif
+	execute @ dup
+	FutureArg nand
+	i = if drop \ skip indent. copy
+	else ." Y" . ." A" i FutureArg nand . getput ." _value" cr endif
hunk ./compiler.fs 297
-	i addr u bind-new-var
-	\ newX addr u bind-new-var
-	\ ." X" lastX . ." A" i . getput ." _value " cr
+	\ i addr u bind-new-var
+	
+	newX addr u bind-new-var
+	." Y" lastX . ." A" i . getput ." _value " cr
hunk ./compiler.fs 313
-: 3drop 2drop drop ;
hunk ./compiler.fs 413
+;
hunk ./compiler.fs 415
+: cleardict
hunk ./compiler.fs 429
-	num-args init
+	cleardict
+	num-args-regalloc init
hunk ./compiler.fs 449
-	num-args init
+	cleardict
+	num-args-regalloc init
hunk ./compiler.fs 488
-	    skip-ws Arrow? not throw next-char next-char skip-ws
-	    compile-body
+	    skip-ws Arrow? not throw next-char next-char
+	    begin
+		skip-ws compile-body
+		skip-ws peek ,? while next-char
+	    repeat
hunk ./compiler.fs 547
+s" qsort([],R,R)." test
+s" qsort([X|L],R0,R) :- split(L,X,L1,L2), qsort(L1,R0,[X|R1]), qsort(L2,R1,R)." test
+
}