1 files changed, 93 insertions, 2 deletions

diff --git a/app/Builtins.hs b/app/Builtins.hs
index eb2dac1..8df703c 100644
--- a/app/Builtins.hs
+++ b/app/Builtins.hs
@@ -9,12 +9,13 @@ import Control.Exception (IOException, catch)
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.Except (runExceptT)
+import Data.Bits
 import Data.Functor.Identity (runIdentity)
 import Data.List (intercalate)
 import qualified Data.Map as M
 import Data.Maybe (fromJust)
 import Env (PrlgEnv(..), findAtom, findStruct, prlgError)
-import Heap (Dereferenced(..), derefHeap, heapStruct, newHeapVars)
+import Heap (Dereferenced(..), derefHeap, heapStruct, newHeapVars, writeHeap)
 import qualified IR
 import Interpreter (backtrack)
 import Lens.Micro.Mtl
@@ -149,6 +150,13 @@ call = exec' id
 exec :: InterpFn
 exec = exec' (const [Done])
 
+stop :: InterpFn
+stop =
+  withArgs [0] $ \[arg] -> do
+    IR.StrTable _ _ itos <- use strtable
+    heap <- use (cur . heap)
+    prlgError $ "stop: " ++ showTerm itos heap arg
+
 {- struct assembly/disassembly -}
 struct :: InterpFn
 struct = do
@@ -218,6 +226,14 @@ var = do
     Just (FreeRef _) -> continue
     _ -> backtrack
 
+number :: InterpFn
+number = do
+  heap <- use (cur . heap)
+  scope <- use (cur . hvar)
+  case derefHeap heap <$> scope M.!? 0 of
+    Just (BoundRef _ (Number _)) -> continue
+    _ -> backtrack
+
 sameTerm :: InterpFn
 sameTerm = do
   heap <- use (cur . heap)
@@ -304,6 +320,57 @@ popExpansions = do
       macrostash .= stash'
       continue
 
+{- integer arithmetics -}
+intBinary :: (Int -> Int -> Int) -> InterpFn
+intBinary op =
+  withArgs [0, 1] $ \[arg1, arg2] -> do
+    heap <- use (cur . heap)
+    case derefHeap heap <$> [arg1, arg2] of
+      [BoundRef _ (Number n1), BoundRef _ (Number n2)] -> putInt (op n1 n2) 2
+      _ -> prlgError "int binary needs numbers"
+
+intBinPred :: (Int -> Int -> Bool) -> InterpFn
+intBinPred op =
+  withArgs [0, 1] $ \args -> do
+    heap <- use (cur . heap)
+    case derefHeap heap <$> args of
+      [BoundRef _ (Number n1), BoundRef _ (Number n2)] ->
+        if op n1 n2
+          then continue
+          else backtrack
+      _ -> prlgError "int binary pred needs numbers"
+
+intUnary :: (Int -> Int) -> InterpFn
+intUnary op =
+  withArgs [0] $ \[arg] -> do
+    heap <- use (cur . heap)
+    case derefHeap heap arg of
+      BoundRef _ (Number n) -> putInt (op n) 1
+      _ -> prlgError "int unary needs number"
+
+intUnPred :: (Int -> Bool) -> InterpFn
+intUnPred op =
+  withArgs [0] $ \[arg] -> do
+    heap <- use (cur . heap)
+    case derefHeap heap arg of
+      BoundRef _ (Number n) ->
+        if op n
+          then continue
+          else backtrack
+      _ -> prlgError "int binary pred needs numbers"
+
+putInt val sc = do
+  heap <- use (cur . heap)
+  scope <- use (cur . hvar)
+  case scope M.!? sc of
+    Nothing -> continue
+    Just a ->
+      case derefHeap heap a of
+        BoundRef _ (Number val')
+          | val == val' -> continue
+        FreeRef a' -> writeHeap a' (Number val) >> continue
+        _ -> backtrack
+
 {- adding the builtins -}
 addOp :: (String, O.Op) -> PrlgEnv ()
 addOp op = ops %= (op :)
@@ -357,9 +424,10 @@ load queryMode =
 addPrelude :: PrlgEnv ()
 addPrelude = do
   pure undefined
-  {- primitives -}
+  {- absolute primitives -}
   addBi (pure Nothing) "true" 0
   addBi backtrack "fail" 0
+  addBi stop "stop" 1
   addOp $ O.xfx "=" 700
   addProc [[U (LocalRef 0), U (LocalRef 0), Done]] "=" 2
   {- clauses -}
@@ -387,6 +455,7 @@ addPrelude = do
   {- terms -}
   addBi struct "struct" 3
   addBi var "var" 1
+  addBi number "number" 1
   addBi sameTerm "same_term" 2
   addBi currentPredicate "current_predicate" 1
   {- code loading -}
@@ -422,6 +491,28 @@ addPrelude = do
           2
   expandCode "load"
   expandCode "query"
+  {- int primops -}
+  let add2IntOp nm op = addBi (intBinary op) ("int2_" ++ nm) 3
+      add1IntOp nm op = addBi (intUnary op) ("int1_" ++ nm) 2
+      add2IntPred nm op = addBi (intBinPred op) ("int2p_" ++ nm) 2
+      add1IntPred nm op = addBi (intUnPred op) ("int1p_" ++ nm) 1
+  add2IntOp "add" (+)
+  add2IntOp "sub" (-)
+  add1IntOp "neg" negate
+  add1IntOp "abs" abs
+  add2IntOp "mul" (*)
+  add2IntOp "div" div
+  add2IntOp "mod" mod
+  add2IntOp "bitand" (.&.)
+  add2IntOp "bitor" (.|.)
+  add2IntOp "bitxor" xor
+  add2IntOp "shl" shiftL
+  add2IntOp "shr" shiftR
+  add1IntPred "zero" (== 0)
+  add2IntPred "eq" (==)
+  add2IntPred "lt" (<)
+  add2IntPred "leq" (<=)
+  add2IntPred "neq" (/=)
   {- query tools -}
   addBi printLocals "print_locals" 0
   addBi promptRetry' "prompt_retry" 0