1 files changed, 46 insertions, 17 deletions

diff --git a/app/Builtins.hs b/app/Builtins.hs
index 555623c..0cdd7cd 100644
--- a/app/Builtins.hs
+++ b/app/Builtins.hs
@@ -2,11 +2,15 @@ module Builtins where
 
 import Code
   ( Builtin(..)
-  , BuiltinFn
   , Cho(..)
   , Datum(..)
+  , Dereferenced(..)
+  , Heap(..)
   , Instr(..)
   , Interp(..)
+  , InterpFn
+  , InterpFn
+  , derefHeap
   , heapStruct
   )
 import qualified Compiler as Co
@@ -16,7 +20,7 @@ import Control.Monad.Trans.State.Lazy (get, gets, modify)
 import Data.Functor.Identity (runIdentity)
 import Data.List (intercalate)
 import qualified Data.Map as M
-import Env (PrlgEnv(..), findAtom, findStruct)
+import Env (PrlgEnv(..), findAtom, findStruct, prlgError)
 import qualified IR
 import Interpreter (backtrack)
 import qualified Operators as O
@@ -37,7 +41,7 @@ showTerm itos heap = runIdentity . heapStruct atom struct hrec heap
          else "_Rec") ++
       show hr
 
-printLocals :: BuiltinFn
+printLocals :: InterpFn
 printLocals = do
   scope <- gets (gvar . cur)
   heap <- gets (heap . cur)
@@ -47,37 +51,39 @@ printLocals = do
     (maybe "_" id $ itos M.!? name) ++ " = " ++ showTerm itos heap ref
   return Nothing
 
-promptRetry :: BuiltinFn
+promptRetry :: InterpFn
 promptRetry = do
   last <- gets (null . cho)
   if last
     then return Nothing
     else promptRetry'
 
-promptRetry' :: BuiltinFn
+promptRetry' :: InterpFn
 promptRetry' = do
   x <- lift $ getInputChar "? "
   case x of
     Just ';' -> backtrack
     _ -> return Nothing
 
-write :: BuiltinFn
-write = do
+write :: InterpFn
+write
+  --TODO: prlgError on write(Unbound)
+ = do
   scope <- gets (hvar . cur)
   heap <- gets (heap . cur)
   IR.StrTable _ _ itos <- gets strtable
   lift . outputStr . showTerm itos heap . fst $ scope M.! 0
   return Nothing
 
-nl :: BuiltinFn
+nl :: InterpFn
 nl = do
   lift $ outputStrLn ""
   return Nothing
 
-writeln :: BuiltinFn
+writeln :: InterpFn
 writeln = write >> nl
 
-assertFact :: BuiltinFn
+assertFact :: InterpFn
 assertFact = do
   scope <- gets (hvar . cur)
   heap <- gets (heap . cur)
@@ -86,9 +92,9 @@ assertFact = do
     Just (U (Struct s):head) -> do
       addClause s $ head ++ [NoGoal]
       return Nothing
-    _ -> backtrack --TODO actually throw
+    _ -> prlgError "assert fact failure"
 
-assertClause :: BuiltinFn
+assertClause :: InterpFn
 assertClause = do
   scope <- gets (hvar . cur)
   heap <- gets (heap . cur)
@@ -101,11 +107,33 @@ assertClause = do
             Co.compileGoal hs ++ Co.seqGoals (Co.compileGoals commaId cut gs)
        in do addClause s cs
              return Nothing
-    _ -> backtrack
-
-retractall :: BuiltinFn
-retractall = do
-  return Nothing
+    _ -> prlgError "assert clause failure"
+
+retractall :: InterpFn
+retractall = prlgError "no retractall yet"
+
+call :: InterpFn
+call = do
+  ref <- gets (fst . (M.! 0) . hvar . cur)
+  heap@(Heap _ hmap) <- gets (heap . cur)
+  let exec base struct arity = do
+        cur <- gets cur
+        modify $ \s ->
+          s
+            { cur =
+                cur
+                  { gol =
+                      [Call, Goal, U struct] ++
+                      [U $ hmap M.! (base + i) | i <- [1 .. arity]] ++ gol cur
+                  }
+            }
+        return Nothing
+  case derefHeap heap ref of
+    BoundRef addr struct@(Struct IR.Id {IR.arity = arity}) ->
+      exec addr struct arity
+    BoundRef addr (Atom a) ->
+      exec addr (Struct IR.Id {IR.arity = 0, IR.str = a}) 0
+    _ -> prlgError "not callable"
 
 {- adding the builtins -}
 addOp op = modify $ \s -> s {ops = op : ops s}
@@ -148,6 +176,7 @@ addPrelude = do
     , [U (LocalRef 0 0), Invoke (bi assertFact)]
     ]
   addProc "retractall" 1 [[U (LocalRef 0 0), Invoke (bi retractall)]]
+  addProc "call" 1 [[U (LocalRef 0 0), Invoke (bi call)]]
   {- query tools -}
   addBi0 "print_locals" printLocals
   addBi0 "prompt_retry" promptRetry'