[Initial version
Adrian Prantl <adrian@complang.tuwien.ac.at>**20081207201912] {
addfile ./compiler.fs
hunk ./compiler.fs 1
+Create VARS table , \  Create a case-sensitive wordlist
+Create X 0 ,
+Create Y 0 ,
+Create A 0 ,
+
+defer term
+defer structure
+defer cons
+
+: newA ( -- u ) A @ dup 1+ A ! ;
+: newX ( -- u ) X @ dup 1+ X ! ;
+: lastX ( -- u ) X @ 1- ;
+
+: x-mode 0 ;
+: a-mode 1 ;
+
+\ SCANNING
+
+: not ( b b ) invert ;
+
+: 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 s\"  peeked\n" type
+;
+
+: peek-next ( addr u -- addr u c )
+    over 1+ c@
+;
+
+: alpha?  ( c -- b ) dup [Char] a [Char] z between swap [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] , = ;
+: 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
+;
+
+: 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 )
+    begin
+	dup 0 <> >r peek ws? r> and while
+	    next-char
+    repeat
+;
+
+: 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 }
+    \ s" TOK: " type addrTok tok_length type cr
+    addrRest u tok_length - addrTok tok_length
+;
+
+: drop3rd rot drop ;
+
+: 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
+;
+
+: nil { mode addr u -- addr u mode addr u } s" []" mode addr u ;
+
+: cons' ( mode addr u -- ... mode addr u )
+    next-char
+    drop3rd x-mode -rot 
+    peek ]? if next-char nil \ nil atom \ s" pushing NIL " type cr
+    else
+	\ Head
+	term skip-ws ~~
+	\ Tail
+	peek ]? if next-char nil else \ end of list
+        peek ,? if cons else
+	    -1 throw
+	endif endif
+	2>r 2 s" ."  ~~ structure 2r> 
+    endif ~~
+;
+' cons' is cons
+
+\ COMPILATION
+
+: atom? peek alpha? ;
+: var? peek vALPHA? ;
+: reg? over 0 = ;
+: nil? ( addr u -- addr u b )
+    dup 1 > if
+	peek [? -rot peek-next ]? and
+    else 0
+    endif
+;
+
+: find-var ( addr u -- xt? b )
+    \ 2dup s" searching for " type type cr
+    VARS search-wordlist
+;
+: bind-new-var ( val addr u -- )
+    get-current { old }
+    VARS set-current
+    \ s" binding " type 2dup type s"  to " type 2over . drop cr
+    nextname create , \  alloc and initialize
+    old set-current
+;
+
+: compile-var { addr u -- }
+    addr u find-var if \  already alloc'd
+	execute @ s" set_value X" type . cr
+    else \   create new
+	newX addr u bind-new-var
+	s" set_variable X" type lastX . cr
+    endif
+;
+
+: compile-var-arg { i addr u -- }
+    addr u find-var if \  already alloc'd
+	execute @ s" put_value X" type . s" , A" type i . cr
+    else \  create new
+	newX addr u bind-new-var
+	s" put_variable X" lastX s" ," . type cr
+    endif
+;
+
+: compile-value ( i addr u -- ) 
+    reg?  if s" set_value X" type . drop cr else
+    var?  if compile-var else
+    nil?  if 2drop s" set_nil" type cr else
+    -1 throw
+    endif endif endif
+    drop
+;
+
+: 3drop 2drop drop ;
+: compile-arg ( i addr u -- )
+    reg?  if 3drop ( s" set_value A" type A @ . cr ) else
+    atom? if throw else \ 0 -rot structure
+    var?  if compile-var-arg else
+    nil?  if 2drop s" put_nil A" type . cr else
+    -1 throw
+    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 -do
+	postpone i postpone 2roll \ reverse argument list
+        postpone newA postpone -rot
+        xt compile,
+        ( postpone r> )
+    1 postpone literal postpone -loop
+;
+
+: structure' ( ... ) { mode nargs addrF uF -- 0 u }
+    s" put_structure " type addrF uF type s" /" type nargs .
+    mode 1 and 1 = if
+	s" , A" type mode 8 rshift . cr 
+    else
+	s" , X" type newX . cr
+    endif
+    nargs [ ' compile-value for-each-arg ]
+    0 lastX
+;
+' structure' is structure
+
+: query ( ... ) { mode nargs addrF uF }
+    nargs [ ' compile-arg for-each-arg ]
+    s" call " type addrF uF type s" /" type nargs . cr
+;
+
+: 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
+;
+
+: var ( mode addr u -- addr u mode addr u )
+    scan-tok { mode addr u addrV uV }
+    \ 2dup s" set_variable " type type cr
+    addrV uV mode addr u \ push VAR
+;
+
+: term' ( mode addr u -- ... mode addr u )
+    skip-ws
+    peek dup alpha? swap Num? or if functor|atom else
+    peek vALPHA?                 if var else
+    peek (?                      if ['] term paren else
+    peek [?                      if cons else
+    throw
+    endif endif endif endif
+    \ IfxOp?        if operator endif
+    \ throw \ "if u != 0" throw
+;
+
+' term' is term
+
+: compile-query ( addr u -- )
+    skip-ws
+    scan-tok { addrF uF }
+    peek (? if \ functor
+	a-mode -rot
+	['] args paren { addrR uR }
+	addrF uF query
+	addrR uR
+	\ push X
+    else \ atom
+	a-mode 0 addrF uF query
+	\ push ATOM
+    endif
+;
+
+: compile ( addr u -- )
+    0 X !
+    0 A !
+    skip-ws
+    Arrow? if
+	next-char next-char
+	compile-query
+    else
+\	Ifx? not throw
+\	compile-head compile-body
+    endif
+;
+
+\ append([], L, L).
+\ append([X|L1], L2, [X|L3]) :- append(L1, L2, L3).
+\
+\ append/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
+\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
+: test ( addr u -- )
+    2dup cr type cr
+    compile
+    clearstack
+;
+s" :- test" scan-tok clearstack
+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
+
+
}