diff options
Diffstat (limited to 'app')
| -rw-r--r-- | app/Builtins.hs | 95 |
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 |