a slightly better call (no compile triggered)

1 files changed, 57 insertions, 40 deletions

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