[Compile buffer (in progress)
Adrian Prantl <adrian@complang.tuwien.ac.at>**20090124160837] {
hunk ./compiler.fs 1
-Create VARS table , \  Create a case-sensitive wordlist
+Create VAR-Dict table , \  Create a case-sensitive wordlist
hunk ./compiler.fs 6
+Create compile-buf-start 4096 chars allot
+Create compile-buf compile-buf-start ,
hunk ./compiler.fs 24
+: 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 )
+    ;
+
+: 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    
+;
+
+\  Compilation buffer handling
+
+: 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 ;
+: functor { addrF uF nargs -- } \ build and push 'f/3'
+    addrF uF push-xt, nargs [Char] / uc->c+str push-xt
+;
+
hunk ./compiler.fs 210
-    \ register allocation for VARS
+    \ register allocation for VAR-Dict
hunk ./compiler.fs 311
-    VARS search-wordlist
+    VAR-Dict search-wordlist
hunk ./compiler.fs 318
-	VARS set-current
+	VAR-Dict set-current
hunk ./compiler.fs 330
-    ." Y" lastX . ." unify_variable" cr
+    lastX Yreg s" unify_variable" push-xt;
hunk ./compiler.fs 341
-		->ar ." A" . ." unify_variable" cr
+		->ar Areg s" unify_variable" push-xt;
hunk ./compiler.fs 343
-	else ->ar ." Y" . ." unify_value" cr endif
+	else ->ar Yreg s" unify_value" push-xt; endif
hunk ./compiler.fs 350
-: getput ( -- ) head? if ." get" else ." put" endif ;
-
+: getput-variable ( -- )
+    head? if s" get_variable" else s" put_variable" endif push-xt ;
+: getput-value ( -- ) head? if s" get_value" else s" put_value" endif push-xt ;
+: getput-nil ( -- ) head? if s" get_nil" else s" put_nil" endif push-xt ;
+: getput-list ( -- ) head? if s" get_list" else s" put_list" endif push-xt ;
+: getput-structure ( -- )
+    head? if s" get_structure" else s" put_structure" endif push-xt ;
hunk ./compiler.fs 360
-    ." Y" lastX . ." A" i . getput ." _variable " cr
+    lastX yreg i areg getput-variable push-cr
hunk ./compiler.fs 372
-	    else ." Y" . ." A" i . getput ." _value" cr endif
+	    else Yreg i Areg getput-value push-cr endif
hunk ./compiler.fs 380
-    reg?  if ." X" . ." put_value???" 2drop cr else
+    reg?  if Xreg getput-value 2drop push-cr else
hunk ./compiler.fs 382
-    nil?  if 3drop ." put_nil" cr else
+    nil?  if 3drop getput-nil push-cr else
hunk ./compiler.fs 392
-    nil?  if 2drop ." A" . ." " getput ." _nil" cr else
+    nil?  if 2drop Areg getput-nil push-cr else
hunk ./compiler.fs 420
-	." X" newX .
+	newX Xreg
hunk ./compiler.fs 422
-	." A" mode 8 rshift . 
+	mode 8 rshift Areg
hunk ./compiler.fs 425
-    nargs addrF uF isList? if getput ." _list " 
-    else addrF uF type ." /" nargs . getput ." _structure " endif
-    cr
+    nargs addrF uF isList? if getput-list 
+    else addrF uF nargs functor getput-structure endif
+    push-cr
hunk ./compiler.fs 440
-    addrF uF type ." /" nargs . ." call" cr
+    addrF uF nargs functor s" call" push-xt;
hunk ./compiler.fs 446
-    addrF uF type ." /" nargs . ." call" cr
+    addrF uF nargs functor s" call" push-xt;
hunk ./compiler.fs 491
-    \ clear VARS dictionary
+    \ clear VAR-Dict dictionary
hunk ./compiler.fs 493
-    VARS set-current
-    s" new-dict" 2dup VARS search-wordlist if execute endif
+    VAR-Dict set-current
+    s" new-dict" 2dup VAR-Dict search-wordlist if execute endif
hunk ./compiler.fs 522
-    ." Cy Cz try_me_else" cr
+    s" Cy Cz try_me_else" push-xt;
hunk ./compiler.fs 571
-	." proceed" cr
+	s" proceed" push-xt;
hunk ./compiler.fs 576
+: run-clause
+    compile-buf-start compile-buf @ over -
+    ( Debug print )
+    2dup type cr
+    ( let gforth compile the clause )
+    evaluate
+;    
+
+
hunk ./compiler.fs 609
-: test ( addr u -- )
+: test-compile ( addr u -- )
+    ( echo )
hunk ./compiler.fs 612
+    ( Clear buffer )
+    compile-buf-start compile-buf !
+    ( Compile )
hunk ./compiler.fs 619
-
hunk ./compiler.fs 620
-s"  :- atom1" test
-s" :- f(a,b)" test
-s" :- f(f(a,b),g(c,h(d,e)))" test
-s" :- p(Z,h(Z,W),f(W))" test
-s" :- f(.(a,.(b,.(c,[]))))" test
-s" :- f([a,b,c])" test
-s" :- f([])" test
-s" :- f([X])" test
-s" :- f([X|[]])" test
-s" :- f([X|Xs])" test
+s"  :- atom1" test-compile
+s" :- f(a,b)" test-compile
+s" :- f(f(a,b),g(c,h(d,e)))" test-compile
+s" :- p(Z,h(Z,W),f(W))" test-compile
+s" :- f(.(a,.(b,.(c,[]))))" test-compile
+s" :- f([a,b,c])" test-compile
+s" :- f([])" test-compile
+s" :- f([X])" test-compile \
+\  wam-allocate
+\  A1 put_list 
+\  Y3 unify_variable
+\  unify-nil
+\  f/1 execute <- letztes Ziel
+\  wam-deallocate
+s" :- f([X|[]])" test-compile
+s" :- f([X|Xs])" test-compile
hunk ./compiler.fs 637
-s" concatenate([],L,L)." test
-s" concatenate([X|L1],L2,[X|L3]) :- concatenate(L1,L2,L3)." test
+s" concatenate([],L,L)." test-compile run-clause
+s" concatenate([X|L1],L2,[X|L3]) :- concatenate(L1,L2,L3)." test-compile
hunk ./compiler.fs 640
-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
+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
}