exa/prlg
1
0
Fork 0
Code Issues Pull requests Actions Packages Projects Releases Wiki Activity

a slightly better call (no compile triggered)

Browse source
This commit is contained in:
Mirek Kratochvil 2023-03-11 18:01:36 +01:00
parent 038bc63b45
commit 4ce2abdd59
1 changed files with 57 additions and 40 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

73
app/Builtins.hs
View file

@ -129,30 +129,19 @@ retractall =
BoundRef _ (Struct id) -> dropProcedure id >> continue BoundRef _ (Struct id) -> dropProcedure id >> continue
_ -> prlgError "retractall needs a struct" _ -> prlgError "retractall needs a struct"
exec' :: (Code -> Code) -> InterpFn call :: InterpFn
exec' fgol = call =
withArgs [0] $ \[arg] -> do withArgs [0] $ \[arg] -> do
heap <- use (cur . heap) heap <- use (cur . heap)
case Co.squashVars <$> Co.heapStructPrlgInt Nothing heap arg of case derefHeap heap arg of
Just gs -> do BoundRef _ (C (Atom a)) -> do
comma <- findAtom "," cur . hed .= [U (Struct (Id {str = a, arity = 0})), Done]
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 continue
Left err -> prlgError err BoundRef addr s@(Struct Id {arity = arity}) -> do
_ -> prlgError "bad goal" cur . hed .= [U s] ++ [U (HeapRef $ addr + i) | i <- [1 .. arity]] ++
[Done]
call :: InterpFn continue
call = exec' id _ -> prlgError "bad call"
exec :: InterpFn
exec = exec' (const [Done])
stop :: InterpFn stop :: InterpFn
stop = stop =
@ -169,8 +158,7 @@ struct = do
case derefHeap heap <$> scope M.!? 0 of case derefHeap heap <$> scope M.!? 0 of
Just (BoundRef _ (Struct Id {arity = arity, str = str})) -> Just (BoundRef _ (Struct Id {arity = arity, str = str})) ->
structUnify arity str structUnify arity str
Just (BoundRef _ _) -> Just (BoundRef _ _) -> backtrack
backtrack
_ -> structAssemble _ -> structAssemble
heapListLength listAtom heap ref = go 0 ref ref (id, fromJust . step) heapListLength listAtom heap ref = go 0 ref ref (id, fromJust . step)
@ -459,8 +447,8 @@ addPrelude = do
addOp $ O.xfy ";" 1100 addOp $ O.xfy ";" 1100
addOp $ O.xfx ":-" 1200 addOp $ O.xfx ":-" 1200
addOp $ O.fx ":-" 1200 addOp $ O.fx ":-" 1200
horn1 <- findStruct ":-" 1 do [horn1, horn2] <- traverse (findStruct ":-") [1, 2]
horn2 <- findStruct ":-" 2 doCall <- U . Struct <$> findStruct "call" 1
let assertCode ac = let assertCode ac =
[ [ U (Struct horn2) [ [ U (Struct horn2)
, U (LocalRef 0) , U (LocalRef 0)
@ -468,14 +456,43 @@ addPrelude = do
, Cut , Cut
, Invoke . bi $ assertRule ac , Invoke . bi $ assertRule ac
] ]
, [U (Struct horn1), U (LocalRef 0), Cut, Invoke $ bi exec] , [ U (Struct horn1)
, U (LocalRef 0)
, Cut
, doCall
, U (LocalRef 0)
, Done
]
, [U (LocalRef 0), Invoke . bi $ assertFact ac] , [U (LocalRef 0), Invoke . bi $ assertFact ac]
] ]
in do addProc (assertCode addClauseA) "asserta" 1 addProc (assertCode addClauseA) "asserta" 1
addProc (assertCode addClauseZ) "assertz" 1 addProc (assertCode addClauseZ) "assertz" 1
addProc (assertCode addClauseZ) "assert" 1 addProc (assertCode addClauseZ) "assert" 1
addBi retractall "retractall" 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 -} {- terms -}
addBi struct "struct" 3 addBi struct "struct" 3
addBi var "var" 1 addBi var "var" 1