diff --git a/app/Builtins.hs b/app/Builtins.hs index 4164a6c..cadf447 100644 --- a/app/Builtins.hs +++ b/app/Builtins.hs @@ -129,30 +129,19 @@ retractall = BoundRef _ (Struct id) -> dropProcedure id >> continue _ -> prlgError "retractall needs a struct" -exec' :: (Code -> Code) -> InterpFn -exec' fgol = +call :: InterpFn +call = withArgs [0] $ \[arg] -> do heap <- use (cur . heap) - case Co.squashVars <$> Co.heapStructPrlgInt Nothing heap arg of - Just gs -> do - comma <- findAtom "," - semi <- findAtom ";" - cut <- findAtom "!" - case Co.compileGoals comma semi cut gs of - Right nhed -> do - zoom cur $ do - hvar .= M.empty - hed .= nhed - gol %= fgol - continue - Left err -> prlgError err - _ -> prlgError "bad goal" - -call :: InterpFn -call = exec' id - -exec :: InterpFn -exec = exec' (const [Done]) + case derefHeap heap arg of + BoundRef _ (C (Atom a)) -> do + cur . hed .= [U (Struct (Id {str = a, arity = 0})), Done] + continue + BoundRef addr s@(Struct Id {arity = arity}) -> do + cur . hed .= [U s] ++ [U (HeapRef $ addr + i) | i <- [1 .. arity]] ++ + [Done] + continue + _ -> prlgError "bad call" stop :: InterpFn stop = @@ -169,8 +158,7 @@ struct = do case derefHeap heap <$> scope M.!? 0 of Just (BoundRef _ (Struct Id {arity = arity, str = str})) -> structUnify arity str - Just (BoundRef _ _) -> - backtrack + Just (BoundRef _ _) -> backtrack _ -> structAssemble heapListLength listAtom heap ref = go 0 ref ref (id, fromJust . step) @@ -459,23 +447,52 @@ addPrelude = do addOp $ O.xfy ";" 1100 addOp $ O.xfx ":-" 1200 addOp $ O.fx ":-" 1200 - horn1 <- findStruct ":-" 1 - horn2 <- findStruct ":-" 2 - let assertCode ac = - [ [ U (Struct horn2) - , U (LocalRef 0) - , U (LocalRef 1) - , Cut - , Invoke . bi $ assertRule ac - ] - , [U (Struct horn1), U (LocalRef 0), Cut, Invoke $ bi exec] - , [U (LocalRef 0), Invoke . bi $ assertFact ac] - ] - in do addProc (assertCode addClauseA) "asserta" 1 - addProc (assertCode addClauseZ) "assertz" 1 - addProc (assertCode addClauseZ) "assert" 1 + do [horn1, horn2] <- traverse (findStruct ":-") [1, 2] + doCall <- U . Struct <$> findStruct "call" 1 + let assertCode ac = + [ [ U (Struct horn2) + , U (LocalRef 0) + , U (LocalRef 1) + , Cut + , Invoke . bi $ assertRule ac + ] + , [ U (Struct horn1) + , U (LocalRef 0) + , Cut + , doCall + , U (LocalRef 0) + , Done + ] + , [U (LocalRef 0), Invoke . bi $ assertFact ac] + ] + addProc (assertCode addClauseA) "asserta" 1 + addProc (assertCode addClauseZ) "assertz" 1 + addProc (assertCode addClauseZ) "assert" 1 addBi retractall "retractall" 1 - addBi call "call" 1 + do [comma, semi] <- traverse (flip findStruct 2) [",", ";"] + doCall <- U . Struct <$> findStruct "call" 1 + addProc + [ [ U (Struct comma) + , U (LocalRef 0) + , U (LocalRef 1) + , Cut + , doCall + , U (LocalRef 0) + , doCall + , U (LocalRef 1) + , Done + ] + , [ U (Struct semi) + , U (LocalRef 0) + , U (LocalRef 1) + , Cut + , Choices [[doCall, U (LocalRef 0)], [doCall, U (LocalRef 1)]] + , Done + ] + , [U (LocalRef 0), Invoke $ bi call] + ] + "call" + 1 {- terms -} addBi struct "struct" 3 addBi var "var" 1