LslPlus-0.1.2: src/Language/Lsl/Internal/Exec.hs
module Language.Lsl.Internal.Exec(
ScriptImage(..),
EvalState,
ExecutionInfo(..),
ExecutionState(..),
FrameInfo(..),
MemRegion,
Binding,
executeLsl,
frameInfo,
initLSLScript,
initStateSimple,
setupSimple,
evalSimple,
emptyMemRegion,
runEval,
scriptImage,
softReset,
hardReset,
hasActiveHandler) where
--import Debug.Trace
import Data.Bits((.&.),(.|.),xor,shiftL,shiftR,complement)
import Data.List(intersperse,find)
import qualified Data.Map as M
import Data.Maybe(isJust)
import Language.Lsl.Internal.Breakpoint(Breakpoint(..),StepManager(..),pushStepManagerFrame,popStepManagerFrame,emptyStepManager,mkBreakpoint)
import Language.Lsl.Internal.CodeHelper(renderCall)
import Language.Lsl.Internal.FuncSigs(funcSigs)
import Language.Lsl.Internal.Util(fromInt,lookupM,ctx,findM)
import Language.Lsl.Syntax(Expr(..),
CompiledLSLScript(..),
Statement(..),
Func(..),
FuncDec(..),
Var(..),
State(..),
Ctx(..),
Global(..),
SourceContext(..),
Handler(..),
ctxVr2Vr,
findFunc,
findFuncDec,
ctxItems,
findState,
fromMCtx,
predefFuncs,
isTextLocation)
import Language.Lsl.Internal.Type(LSLType(..),LSLValue(..),typeOfLSLComponent,typeOfLSLValue,toFloat,toSVal,
lslShowVal,replaceLslValueComponent,vecMulScalar,rotMulVec,
parseInt,parseFloat,invRot,rotMul,vcross,Component(..),lslValueComponent)
import Language.Lsl.Internal.Key(nullKey,nextKey)
import Language.Lsl.Internal.Evaluation(EvalResult(..),Event(..),ScriptInfo(..))
import Language.Lsl.Internal.Constants(findConstVal,llcZeroRotation,llcZeroVector)
import Control.Monad(foldM_,when,mplus,msum,join,zipWithM)
import Control.Monad.State(lift,StateT(..))
import Control.Monad.Error(ErrorT(..))
-- initialize a script for execution
initLSLScript :: CompiledLSLScript -> ScriptImage
initLSLScript (CompiledLSLScript globals fs ss) =
ScriptImage {
scriptImageName = "",
curState = "default",
executionState = Waiting,
glob = initGlobals globals,
funcs = fs,
states = ss,
valueStack = [],
callStack = [],
stepManager = emptyStepManager,
globals = globals,
currentEvent = Nothing }
initStateSimple script perfAction log qtick utick chkBp =
EvalState { scriptImage = initLSLScript script,
objectId = nextKey nullKey,
primId = 0,
scriptName = "script",
myPrimKey = nextKey nullKey,
performAction = perfAction,
logMessage = log,
qwtick = qtick,
uwtick = utick,
checkBreakpoint = chkBp,
nextEvent = undefined }
runEval = (runStateT . runErrorT)
executeLsl img oid pid sid pkey perfAction log qtick utick chkBp queue maxTick =
do let state = (EvalState { scriptImage = img,
objectId = oid,
primId = pid,
scriptName = sid,
myPrimKey = pkey,
performAction = perfAction,
logMessage = log,
qwtick = qtick,
uwtick = utick,
checkBreakpoint = chkBp,
nextEvent = undefined})
result <- (runEval $ evalScript maxTick queue) state
case result of
(Left s,_) -> return $ Left s
(Right queue',evalState) -> return $ Right $ (scriptImage evalState, queue')
-- The state of evaluation for a script.
data EvalState m = EvalState {
scriptImage :: ScriptImage,
objectId :: String,
primId :: Int,
scriptName :: String,
myPrimKey :: String,
performAction :: String -> ScriptInfo -> [LSLValue] -> m (EvalResult,LSLValue),
logMessage :: String -> m (),
qwtick :: m Int,
uwtick :: Int -> m (),
checkBreakpoint :: Breakpoint -> StepManager -> m (Bool, StepManager),
nextEvent :: String -> String -> m (Maybe Event) }
type Eval m = ErrorT String (StateT (EvalState m) m)
evalT :: Monad m => ((EvalState m) -> (a,EvalState m)) -> Eval m a
evalT v = lift ((\ f -> StateT (\ s -> return (f s))) v)
-- the image, or 'memory state' of a running script. Includes the
-- status of all stacks, global variables, and immutable items like
-- the functions and state definitions.
data ScriptImage = ScriptImage {
scriptImageName :: String,
curState :: StateName,
executionState :: ExecutionState,
glob :: MemRegion,
funcs :: [Func],
states :: [State],
valueStack :: ValueStack,
callStack :: CallStack,
stepManager :: StepManager,
globals :: [Global],
currentEvent :: Maybe Event
} deriving (Show)
data FrameInfo = FrameInfo { frameInfoImageName :: String, frameInfoFrames :: [(String,SourceContext,Maybe Int,[(String,LSLValue)])] }
deriving (Show)
frameInfo scriptImage = FrameInfo (scriptImageName scriptImage) $
frames ++ [("glob", bottomContext, Nothing, glob scriptImage)]
where frames = (map collapseFrame $ callStack scriptImage)
(bottomContext,bottomLine) = case frames of
[] -> (UnknownSourceContext,Nothing)
_ -> let (_,ctx,_,_) = last frames in (ctx,Just 1)
collapseFrame (Frame name ctx line (ss,_)) =
(name,ctx,line,concat $ map fst ss)
-- a soft reset occurs when a script that has been running, but
-- has been persisted to inventory, is reactivated. The curState
-- stays the same, but if the script was running or sleeping, the
-- script goes to the 'waiting' state, with its call stack and value
-- stack cleared.
-- if a script was halted, it stays halted; if it was waiting, it
-- stays waiting; if it was erroneous, it stays erroneous
softReset image =
let image' = image { valueStack = [], callStack = [] } in
case executionState image' of
SleepingTil _ -> image' { executionState = Waiting }
Executing -> image' { executionState = Waiting }
_ -> image'
-- a hard reset occurs when a script is explicitly reset, either
-- via an LSL call, or 'manually' (in the real SL, via the GUI)
hardReset image =
case executionState image of
Erroneous _ -> image -- no effect
Halted -> image -- halted scripts are scripts that are explicitly not in the run state
_ -> image {
curState = "default",
executionState = Waiting,
glob = initGlobals (globals image),
valueStack = [],
callStack = [] }
type StateName = String
-- a labeled block: a label and all the statements that follow it.
data LBlock = LBlock String [Ctx Statement]
deriving (Show)
-- find a block in a list of labeled blocks
findLBlock name = find (\ (LBlock n _) -> name == n)
-- label the blocks in a list of statements `(i.e.
-- (EXAMPLE:
-- {
-- @foo;
-- if (i == 7) jump bar;
-- @bar;
-- llSay(0, (string) (i + j));
-- if (j == 10) jump foo;
-- }
-- In the above code, there are two labels, and there for two labelled
-- blocks. The first is 'foo', labelling the block:
-- if (i == 7) jump bar;
-- @bar;
-- llSay(0, (string) (i + j));
-- if (j == 10) jump foo;
--
-- The 2nd is 'bar', labelling the block:
-- llSay(0, (string) (i + j));
-- if (j == 10) jump foo;
--
labelBlocks [] = []
-- labelBlocks ((Label s):stmts) = (LBlock s stmts):(labelBlocks stmts)
-- labelBlocks (_:stmts) = (labelBlocks stmts)
labelBlocks (ctxStmt:stmts) =
case ctxItem ctxStmt of
Label s -> (LBlock s stmts):(labelBlocks stmts)
_ -> (labelBlocks stmts)
-- A name/element pair is the basic unit of memory. Each memory
-- location has a name (rather than an address) and can hold a value
-- which can be of any LSL type. So 1 memory location can hold a
-- vector, or a string, or a list, etc.
type Binding = (String,LSLValue)
-- a memory region is just a collection of NameElementPairs
type MemRegion = [Binding]
emptyMemRegion = []
initVar name LLInteger Nothing = (name,IVal 0)
initVar name LLFloat Nothing = (name,FVal 0.0)
initVar name LLString Nothing = (name,SVal "")
initVar name LLKey Nothing = (name,SVal "")
initVar name LLList Nothing = (name,LVal [])
initVar name LLVector Nothing = (name,VVal 0.0 0.0 0.0)
initVar name LLRot Nothing = (name,RVal 0.0 0.0 0.0 1.0)
initVar name LLKey (Just (SVal s)) = (name,KVal s)
initVar name LLString (Just (KVal k)) = (name, SVal k)
initVar name LLFloat (Just (IVal i)) = (name,FVal $ fromInt i)
initVar name LLInteger (Just (FVal f)) = (name,IVal $ floor f)
initVar name _ (Just v) = (name,v)
writeMem :: Monad m => String -> LSLValue -> MemRegion -> m MemRegion
writeMem name value cells =
case break (\(name',element) -> name' == name) cells of
(cells',[]) -> fail "no such variable"
(xs,y:ys) -> return ((name,value):(xs ++ ys))
readMem :: Monad m => String -> MemRegion -> m LSLValue
readMem = lookupM
initGlobals :: [Global] -> MemRegion
initGlobals globals = map (initGlobal globals) globals
initGlobal globals (GDecl (Var name t) mexpr) = initVar name t $ fmap (evalLit globals) mexpr
evalCtxLit globals (Ctx _ expr) = evalLit globals expr
evalLit globals expr =
let litExpr2Float expr =
case evalCtxLit globals expr of
(FVal f) -> f
(IVal i) -> fromInteger $ toInteger i
_ -> error "invalid float expression"
in case expr of
Neg (Ctx _ (IntLit i)) -> IVal (-i)
Neg (Ctx _ (FloatLit f)) -> FVal (-f)
IntLit i -> IVal i
FloatLit f -> FVal f
StringLit s -> SVal s
KeyLit k -> KVal k
ListExpr l -> LVal $ map (evalCtxLit globals) l
VecExpr a b c -> VVal (litExpr2Float a) (litExpr2Float b) (litExpr2Float c)
RotExpr a b c d -> RVal (litExpr2Float a) (litExpr2Float b) (litExpr2Float c) (litExpr2Float d)
Get (Ctx _ nm,All) ->
case find (\ (GDecl (Var nm' t) mexpr') -> nm == nm') globals of
Nothing ->
case findConstVal nm of
Nothing -> error ("invalid global " ++ nm ++ " referenced in initializer")
Just v -> v
Just g ->
let (_,v) = initGlobal globals g in v
bindParm (Var name t) lslVal = if typeOfLSLValue lslVal == t then return (name,lslVal) else fail "type mismatch!"
bindParms vars vals = zipWithM bindParm vars vals
bindParmForgiving (Var name t) lslVal =
case (t,typeOfLSLValue lslVal) of
(LLInteger,LLFloat) -> let FVal v = lslVal in return (name,IVal $ floor v)
(LLFloat,LLInteger) -> let IVal v = lslVal in return (name,FVal $ fromInt v)
(LLKey,LLString) -> let SVal s = lslVal in return (name,KVal s)
(LLString,LLKey) -> let KVal k = lslVal in return (name,SVal k)
(t0,t1) | t0 == t1 -> return (name,lslVal)
| otherwise -> fail "type mismatch!"
bindParmsForgiving vars vals = zipWithM bindParmForgiving vars vals
toBool x = if x == 0 then False else True
--type Frame = (ScopeStack,EvalStack)
data Frame = Frame { frameName :: String, frameContext :: SourceContext, frameSourceLine :: Maybe Int,
frameStacks :: (ScopeStack, EvalStack) }
deriving (Show)
type LabelSet = [LBlock]
type Scope = (MemRegion,LabelSet)
type ScopeStack = [Scope]
type CallStack = [Frame]
readVarScope :: String -> Scope -> Maybe LSLValue
readVarScope name (mem,_) = readMem name mem
readVarSStack :: String -> ScopeStack -> Maybe LSLValue
readVarSStack name ss = foldl mplus Nothing $ map (readVarScope name) ss
readVarFrame :: String -> Frame -> Maybe LSLValue
readVarFrame name = (readVarSStack name) . fst . frameStacks
readVarCallStack :: String -> CallStack -> Maybe LSLValue
readVarCallStack name = (readVarFrame name) . head
writeVarScope :: String -> LSLValue -> Scope -> Maybe Scope
writeVarScope name val (mem,l) = writeMem name val mem >>= return . (flip (,) l)
writeVarSStack rs name val [] = Nothing
writeVarSStack rs name val (s:ss) =
case writeVarScope name val s of
Nothing -> writeVarSStack (s:rs) name val ss
Just s' -> Just $ (reverse rs) ++ (s':ss)
writeVarFrame name val frame =
let (ss,es) = frameStacks frame in
case writeVarSStack [] name val ss of
Nothing -> Nothing
Just ss' -> Just frame { frameStacks = (ss',es) }
writeVarCallStack name val (frame:cs) = writeVarFrame name val frame >>= return . (flip (:) cs)
type EvalStack = [EvalElement]
type ValueStack = [LSLValue]
data EvalElement = EvBlock [Ctx Statement] | EvCtxStatement (Ctx Statement)
| EvStatement Statement | EvExpr Expr | EvMexpr (Maybe Expr)
| EvAdd | EvSub | EvMul | EvDiv | EvMod | EvBAnd | EvBOr | EvBXor | EvBInv | EvNeg
| EvNot | EvAnd | EvOr | EvLe | EvLt | EvGe | EvGt | EvEq | EvNe
| EvShiftL | EvShiftR | EvCast LSLType | EvGet (String,Component) | EvSet (String,Component)
| EvCons | EvMkVec | EvMkRot | EvPop
| EvReturn | EvDiscard | EvBind String LSLType
| EvCond Statement Statement | EvCall String SourceContext [Var] [Ctx Statement] Bool
| EvPredef String | EvLoop Expr [Ctx Expr] Statement
deriving (Show)
-- Note: lifted from Hudak, p.273
queryState :: Monad w => (EvalState w -> a) -> Eval w a
queryState q = evalT (\s -> (q s, s))
updateState :: Monad w => (EvalState w -> EvalState w) -> Eval w ()
updateState u = evalT (\s -> ((), u s))
queryExState q = queryState (q . scriptImage)
updateExState :: Monad w => (ScriptImage -> ScriptImage) -> Eval w ()
updateExState u = updateState (\s -> s { scriptImage = u $ scriptImage s })
getTick :: Monad w => Eval w Int
getTick = join $ evalT (\s -> (lift $ lift $ qwtick s,s))
setTick v = do f <- (queryState uwtick)
lift $ lift $ f v
getNextEvent key name = do f <- (queryState nextEvent)
lift $ lift $ f key name
doAction name scriptInfo args = do perform <- (queryState performAction)
lift $ lift $ perform name scriptInfo args
logMsg s = do log <- queryState logMessage
lift $ lift $ log s
checkBp bp = do sm <- getStepManager
chk <- queryState checkBreakpoint
(result,sm') <- lift $ lift $ chk bp sm
setStepManager sm'
return result
getGlob :: Monad w => Eval w MemRegion
getGlob = queryExState glob
getFuncs :: Monad w => Eval w [Func]
getFuncs = queryExState funcs
getVStack :: Monad w => Eval w ValueStack
getVStack = queryExState valueStack
getCallStack :: Monad w => Eval w CallStack
getCallStack = queryExState callStack
getStates :: Monad w => Eval w [State]
getStates = queryExState states
getCurrentEvent :: Monad w => Eval w (Maybe Event)
getCurrentEvent = queryExState currentEvent
getExecutionState :: Monad w => Eval w ExecutionState
getExecutionState = queryExState executionState
getCurState :: Monad w => Eval w String
getCurState = queryExState curState
getEvalState :: Monad w => Eval w (EvalState w)
getEvalState = queryState id
getObjectId :: Monad w => Eval w String
getObjectId = queryState objectId
getPrimId :: Monad w => Eval w Int
getPrimId = queryState primId
getScriptName :: Monad w => Eval w String
getScriptName = queryState scriptName
getScriptImageName :: Monad w => Eval w String
getScriptImageName = queryExState scriptImageName
getMyPrimKey :: Monad w => Eval w String
getMyPrimKey = queryState myPrimKey
getStepManager :: Monad w => Eval w StepManager
getStepManager = queryExState stepManager
setGlob g = updateExState (\e -> e { glob = g })
setVStack v = updateExState (\e -> e { valueStack = v })
setCallStack c = updateExState (\e -> e { callStack = c })
setStepManager m = updateExState (\e -> e { stepManager = m })
setExecutionState state = updateExState (\e -> e { executionState = state })
setCurState state = updateExState (\e -> e { curState = state })
setCurrentEvent event = updateExState (\e -> e { currentEvent = Just event })
setScriptImageName n = updateExState (\ e -> e { scriptImageName = n })
initStacks :: Monad w => Eval w ()
initStacks =
do setVStack []
setCallStack []
popScope :: Monad w => Eval w Scope
popScope =
do --((s:ss,es):cs) <- getCallStack
(frame:frames) <- getCallStack
let (s:ss,es) = frameStacks frame
setCallStack (frame { frameStacks = (ss,es) }:frames)
return s
pushScope :: Monad w => MemRegion -> LabelSet -> Eval w ()
pushScope mem labels =
do (frame:frames) <- getCallStack
let (ss,es) = frameStacks frame
setCallStack (frame { frameStacks = ((mem,labels):ss,es) }:frames)
pushVal value =
do vstack <- getVStack
setVStack (value:vstack)
popVal :: Monad w => Eval w LSLValue
popVal =
do vstack <- getVStack
case vstack of
[] -> fail "empty value stack"
(v:vs) -> do
setVStack vs
return v
peekVal :: Monad w => Eval w LSLValue
peekVal =
do vstack <- getVStack
case vstack of
[] -> fail "empty value stack"
(v:_) -> return v
valStackEmpty :: Monad w => Eval w Bool
valStackEmpty = getVStack >>= (return . (==[]))
elementStackEmpty :: Monad w => Eval w Bool
elementStackEmpty =
do (frame:cs) <- getCallStack
case frameStacks frame of
(_,[]) -> return True
_ -> return False
popElement :: Monad w => Eval w EvalElement
popElement =
do (frame:frames) <- getCallStack
let (ss,e:es) = frameStacks frame
setCallStack (frame { frameStacks = (ss,es) }:frames)
return e
popElements 0 = return ()
popElements n =
do popElement
popElements (n - 1)
pushElement element =
do (frame:frames) <- getCallStack
let (ss,es) = frameStacks frame
setCallStack (frame { frameStacks = (ss,element:es) }:frames)
pushElements elements =
do mapM pushElement elements
return EvalIncomplete
callStackEmpty :: Monad w => Eval w Bool
callStackEmpty = getCallStack >>= return . null
popFrame :: Monad w => Eval w ()
popFrame =
do (f:cs) <- getCallStack
stepMgr <- getStepManager
let stepMgr' = popStepManagerFrame stepMgr
setStepManager stepMgr'
setCallStack cs
--pushFrame :: Monad w => Eval w ()
pushFrame name ctx line =
do stepMgr <- getStepManager
let stepMgr' = pushStepManagerFrame stepMgr
setStepManager stepMgr'
cs <- getCallStack
setCallStack (Frame { frameName = name, frameContext = ctx, frameSourceLine = line, frameStacks = ([],[])}:cs)
getFunc :: Monad w => String -> Eval w Func
getFunc name =
do funcs <- getFuncs
incontext ("func: " ++ name) $ findFunc name funcs
setVar :: Monad w => String -> LSLValue -> Eval w ()
setVar name val =
do cs <- getCallStack
case writeVarCallStack name val cs of
Just cs' -> setCallStack cs'
Nothing ->
do glob <- getGlob
glob' <- incontext ("setting " ++ name ++ ":") $ writeMem name val glob
setGlob glob'
getVar :: Monad w => String -> Eval w LSLValue
getVar name =
do cs <- getCallStack
glob <- getGlob
case msum [findConstVal name, readVarCallStack name cs, readMem name glob] of
Nothing -> fail ("no such variable " ++ name)
Just val -> return val
initVar1 :: Monad w => String -> LSLType -> Maybe LSLValue -> Eval w ()
initVar1 name t mval =
do --(((m,l):ss,es):cs) <- getCallStack
(frame:frames) <- getCallStack
let ((m,l):ss,es) = frameStacks frame
let frame' = frame { frameStacks = (((initVar name t mval):m,l):ss,es) }
setCallStack (frame':frames)
initVars1 :: Monad w => [Var] -> [LSLValue] -> Eval w ()
initVars1 vars vals =
foldM_ (\_ -> \ (Var n t, v) -> initVar1 n t $ Just v) () $ zip vars vals
unwindToLabel name =
let f n =
do (frame:frames) <- getCallStack
let (ss,es) = frameStacks frame
case ss of
[] -> fail ("label " ++ name ++ " not found")
((m,l):ss') ->
case findLBlock name l of
Just (LBlock _ stmts) -> return $ (n,stmts)
Nothing ->
do setCallStack (frame { frameStacks = (ss',es) }:frames)
f (n + 1)
in f 1
data ExecutionState = Waiting | Executing | Halted | SleepingTil Int | Erroneous String | Crashed String | Suspended Breakpoint
| WaitingTil Int -- in a waiting state, but won't process new events until time t
deriving (Show,Eq)
matchEvent (Event name _ _) [] = fail ("no such handler" ++ name)
matchEvent event@(Event name values _) ((Handler (Ctx ctx name') parms stmts):hs)
| name == name' = do mem <- bindParms (ctxItems parms) values
return (mem,stmts,name,ctx)
| otherwise = matchEvent event hs
findHandler name handlers = ctx ("finding handler " ++ name) $
findM (\ (Handler (Ctx _ name') _ _) -> name' == name) handlers
evalScriptSimple :: Monad w => Int -> [String] -> [Binding] -> [LSLValue] -> Eval w (EvalResult,Maybe LSLValue)
evalScriptSimple maxTick path globbindings args =
do setupSimple path globbindings args
evalSimple maxTick
evalSimple maxTick =
do result <- eval maxTick
glob <- getGlob
case result of
EvalComplete Nothing ->
do empty <- valStackEmpty
if empty then return (result,Just VoidVal) else do
val <- popVal
return (result,Just val)
_ -> return (result,Nothing)
setupSimple path globbindings args =
do setScriptImageName (concat (intersperse "." path))
updateGlobals globbindings
(params,stmts,ctx) <- getEntryPoint path
mem <- bindParmsForgiving params args
initStacks
pushFrame (concat $ intersperse "." path) ctx Nothing
pushScope mem $ labelBlocks stmts
pushElement (EvBlock stmts)
setExecutionState Executing
where updateGlobals [] = return ()
updateGlobals ((name,val):bs) =
do glob <- getGlob
glob' <- writeMem name val glob
setGlob glob'
updateGlobals bs
getEntryPoint [funcName] =
do funcs <- getFuncs
(Func (FuncDec name _ params) stmts) <- findFunc funcName funcs
return (ctxItems params,stmts,srcCtx name)
getEntryPoint [stateName,handlerName] =
do states <- getStates
(State _ handlers) <- findState stateName states
(Handler name params stmts) <- findHandler handlerName handlers
return (ctxItems params,stmts, srcCtx name)
incontext s f =
case f of
Left s -> fail s
Right v -> return v
evalScript :: Monad w => Int -> [Event] -> Eval w [Event]
evalScript maxTick queue =
do executionState <- getExecutionState
case executionState of
Suspended _ -> setExecutionState Executing >> evalScript maxTick queue
Erroneous _ -> return queue
Waiting ->
do oid <- getObjectId
pid <- getPrimId
primKey <- getMyPrimKey
scriptName <- getScriptName
case queue of
[] -> return queue
(event:queue') ->
do states <- getStates
curState <- case event of
-- when a state_exit event occurs we've already changed the state variable in the image
-- to the new state. the event itself contains the name of the old state, so we can
-- find the right event handler.
Event "state_exit" _ m ->
case M.lookup "last_state" m of
Just (SVal s) -> return s
Nothing -> logMsg "not a valid state exit!" >> getCurState
_ -> getCurState
(State _ handlers) <- incontext ("state " ++ curState ++ ":") $ findState curState states
case matchEvent event handlers of
Nothing -> return queue'
Just (mem,stmts,name,ctx) ->
do initStacks
pushFrame name ctx Nothing
pushScope mem $ labelBlocks stmts
pushElement (EvBlock stmts)
setExecutionState Executing
setCurrentEvent event
evalScript maxTick queue'
Executing -> do result <- eval maxTick
case result of
EvalComplete (Just newState) ->
do curState <- getCurState
setCurState newState
setExecutionState Waiting
if curState /= newState
-- the event queue gets cleared, with the state exit/entry events added.
then return [Event "state_exit" [] $ M.singleton "last_state" (SVal curState),
Event "state_entry" [] $ M.empty]
else return queue
EvalComplete _ -> setExecutionState Waiting >> return queue
YieldTil i -> setExecutionState (SleepingTil i) >> return queue
BrokeAt bp -> setExecutionState (Suspended bp) >> return queue
_ -> return queue
SleepingTil i -> do tick <- getTick
if (tick >= i)
then setExecutionState Executing >> evalScript maxTick queue
else return queue
WaitingTil i -> do tick <- getTick
if (tick >= i)
then setExecutionState Waiting >> evalScript maxTick queue
else return queue
Halted -> return queue
eval :: Monad w => Int -> Eval w EvalResult
eval maxTick =
do
t <- getTick
let t' = t + 1
setTick t'
(if (t' <= maxTick) then
do result <- eval'
case result of
EvalIncomplete -> eval maxTick
x -> return x
else
return EvalIncomplete)
eval' :: Monad w => Eval w EvalResult
eval' =
let continue = return EvalIncomplete
popAndCheck :: Monad w => Eval w EvalResult
popAndCheck = do
popFrame
noMoreFrames <- callStackEmpty
return (if noMoreFrames then EvalComplete Nothing else EvalIncomplete)
in
do cs <- getCallStack
vs <- getVStack
noMoreElements <- elementStackEmpty
if noMoreElements then popAndCheck
else do
element <- popElement
case element of
EvReturn -> do
val <- peekVal
logMsg ("return: " ++ lslShowVal val)
popAndCheck
EvBlock [] -> popScope >> eval'
EvBlock (s:ss) -> pushElements [EvBlock ss,EvCtxStatement s]
EvCtxStatement s -> do
pushElements [EvStatement $ ctxItem s]
if (isTextLocation $ srcCtx s) then
let bp = mkBreakpoint (textName $ srcCtx s) (textLine0 $ srcCtx s) 0 in
do brk <- checkBp bp
if brk then return $ BrokeAt bp
else continue
else continue
EvStatement (Return mexpr) -> pushElements [EvReturn,EvMexpr $ fromMCtx mexpr]
EvStatement (NullStmt) -> eval'
EvStatement (StateChange s) -> return $ EvalComplete $ Just s
EvStatement (Do expr) -> pushElements [EvDiscard,EvExpr $ ctxItem expr]
EvStatement (Decl (Var name t) Nothing) ->
do initVar1 name t Nothing
continue
EvStatement (Decl (Var name t) mexpr) -> pushElements [EvBind name t,EvMexpr $ fromMCtx mexpr]
EvStatement (If expr stmt1 stmt2) -> pushElements [EvCond stmt1 stmt2,EvExpr $ ctxItem expr]
EvStatement (While expr stmt) -> pushElements [EvLoop (ctxItem expr) [] stmt,EvExpr $ ctxItem expr]
EvStatement (DoWhile stmt expr) ->
pushElements [EvLoop (ctxItem expr) [] stmt, EvExpr (ctxItem expr),EvStatement stmt]
EvStatement (For mexpr1 mexpr2 mexpr3 stmt) ->
do let expr = case mexpr2 of
Nothing -> (IntLit 1)
Just expr2 -> ctxItem expr2
pushElement (EvLoop expr (mexpr3) stmt)
pushElement (EvExpr $ expr)
pushElements [EvDiscard, EvExpr (ListExpr mexpr1)]
continue
EvStatement (Compound ss) ->
do pushScope [] $ labelBlocks ss
pushElement (EvBlock ss)
continue
EvStatement (Label _) -> eval'
EvStatement (Jump name) ->
do (n,stmts) <- unwindToLabel name
popElements n
pushElement (EvBlock stmts)
continue
EvMexpr Nothing -> pushVal VoidVal >> continue
EvMexpr (Just expr) -> pushElements [EvExpr expr]
EvDiscard -> popVal >> continue
EvBind name t ->
do val <- popVal
initVar1 name t (Just val)
continue
EvLoop expr mexpr stmt ->
do val <- popVal
when (trueCondition val) $ do
pushElement element -- last, re-evaluate loop
pushElement (EvExpr expr) -- next-to-last, re-evaluate expr)
pushElements [EvDiscard, EvExpr (ListExpr mexpr)] -- evaluate end-of-loop expressions
pushElement (EvStatement stmt) -- first, evaluate statement)
continue
EvCond stmt1 stmt2 ->
do val <- popVal
pushElement (EvStatement (if trueCondition val then stmt1 else stmt2))
continue
EvExpr (IntLit i) -> pushVal (IVal i) >> continue
EvExpr (FloatLit f) -> pushVal (FVal f) >> continue
EvExpr (StringLit s) -> pushVal (SVal s) >> continue
EvExpr (KeyLit k) -> pushVal (KVal k) >> continue
EvExpr (VecExpr e1 e2 e3) ->
-- TODO: this is probably the WRONG order of evaluation!!!
pushElements [EvMkVec,EvExpr $ ctxItem e3, EvExpr $ ctxItem e2, EvExpr $ ctxItem e1]
EvExpr (RotExpr e1 e2 e3 e4) ->
pushElements [EvMkRot,EvExpr $ ctxItem e4, EvExpr $ ctxItem e3, EvExpr $ ctxItem e2, EvExpr $ ctxItem e1]
EvExpr (ListExpr []) -> pushVal (LVal []) >> continue
EvExpr (ListExpr ((Ctx _ e):es)) ->
pushElements [EvCons,EvExpr (ListExpr es), EvExpr e]
EvExpr (Add expr1 expr2) -> pushBinary EvAdd expr1 expr2
EvExpr (Sub expr1 expr2) -> pushBinary EvSub expr1 expr2
EvExpr (Mul expr1 expr2) -> pushBinary EvMul expr1 expr2
EvExpr (Div expr1 expr2) -> pushBinary EvDiv expr1 expr2
EvExpr (Mod expr1 expr2) -> pushBinary EvMod expr1 expr2
EvExpr (BAnd expr1 expr2) -> pushBinary EvBAnd expr1 expr2
EvExpr (BOr expr1 expr2) -> pushBinary EvBOr expr1 expr2
EvExpr (Xor expr1 expr2) -> pushBinary EvBXor expr1 expr2
EvExpr (And expr1 expr2) -> pushBinary EvAnd expr1 expr2
EvExpr (Or expr1 expr2) -> pushBinary EvOr expr1 expr2
EvExpr (Lt expr1 expr2) -> pushBinary EvLt expr1 expr2
EvExpr (Le expr1 expr2) -> pushBinary EvLe expr1 expr2
EvExpr (Gt expr1 expr2) -> pushBinary EvGt expr1 expr2
EvExpr (Ge expr1 expr2) -> pushBinary EvGe expr1 expr2
EvExpr (Equal expr1 expr2) -> pushBinary EvEq expr1 expr2
EvExpr (NotEqual expr1 expr2) -> pushBinary EvNe expr1 expr2
EvExpr (ShiftL expr1 expr2) -> pushBinary EvShiftL expr1 expr2
EvExpr (ShiftR expr1 expr2) -> pushBinary EvShiftR expr1 expr2
EvExpr (Not expr) -> pushUnary EvNot expr
EvExpr (Neg expr) -> pushUnary EvNeg expr
EvExpr (Inv expr) -> pushUnary EvBInv expr
EvExpr (Cast t expr) -> pushElements [EvCast t,EvExpr $ ctxItem expr]
EvExpr (Get var) -> pushElements [EvGet $ ctxVr2Vr var]
EvExpr (Set var expr) -> pushElements [EvSet $ ctxVr2Vr var, EvExpr $ ctxItem expr]
EvExpr (IncBy var expr) -> pushModBy var EvAdd $ ctxItem expr
EvExpr (DecBy var expr) -> pushModBy var EvSub $ ctxItem expr
EvExpr (MulBy var expr) -> pushModBy var EvMul $ ctxItem expr
EvExpr (DivBy var expr) -> pushModBy var EvDiv $ ctxItem expr
EvExpr (ModBy var expr) -> pushModBy var EvMod $ ctxItem expr
EvExpr (PreInc var) -> pushModBy var EvAdd (IntLit 1)
EvExpr (PreDec var) -> pushModBy var EvSub (IntLit 1)
EvExpr (PostInc var) ->
do -- after all operations, top of stack should be var value prior to increment
pushElement (EvPop) -- take that value off, leaving the original value
pushModBy var EvAdd (IntLit 1)
pushElement (EvGet $ ctxVr2Vr var) -- put the current value on the stack
continue
EvExpr (PostDec var) ->
do -- after all operations, top of stack should be var value prior to increment
pushElement (EvPop)
pushModBy var EvSub (IntLit 1)
pushElement (EvGet $ ctxVr2Vr var) -- put the current value on the stack
continue
EvExpr (Call (Ctx _ name) exprs) ->
case findFuncDec name predefFuncs of
Just (FuncDec _ t parms) -> pushElements [EvPredef name, EvExpr (ListExpr exprs)]
Nothing ->
do
(Func (FuncDec ctxName t parms) stmts) <- getFunc name
pushElement (EvCall (ctxItem ctxName) (srcCtx ctxName) (ctxItems parms) stmts (t == LLVoid))
pushElement (EvExpr (ListExpr exprs)) -- first evaluate the arguments
continue
EvCons ->
do (LVal l) <- popVal
val <- popVal
pushVal (LVal (val:l))
continue
EvCall name ctx parms stmts voidFunc ->
do (LVal val) <- popVal -- should be the list of arguments
logMsg ("call: " ++ renderCall name val)
pushFrame name ctx Nothing
pushScope [] $ labelBlocks stmts
initVars1 parms val
-- a void function may not have an explicit return; if it does, this
-- element will get popped off without being evaluated.
when voidFunc (pushElement EvReturn >> pushElement (EvMexpr Nothing))
pushElement (EvBlock stmts)
continue
EvPredef name -> evalPredef' name
EvGet (name,c) ->
do val <- getVar name
pushVal $ lslValueComponent c val
continue
EvPop -> popVal >> continue
EvSet (name,c) ->
do val <- peekVal
varVal <- getVar name
let t = typeOfLSLComponent varVal c
let val' = case (t,val) of
(LLFloat,IVal i) -> FVal (fromInt i)
(LLString,KVal k) -> SVal k
(LLKey,SVal s) -> KVal s
(t, v) | t == typeOfLSLValue v -> v
| otherwise -> error ("can't implicitly convert from " ++
(show $ typeOfLSLValue v) ++
" to " ++ (show t))
let varVal' = replaceLslValueComponent c varVal val'
setVar name varVal'
continue
EvAdd -> evalBinary $ \val1 val2 -> case (val1,val2) of
(IVal v1, IVal v2) -> IVal (v1 + v2)
(FVal v1, IVal v2) -> FVal (v1 + fromInt v2)
(IVal v1, FVal v2) -> FVal (v2 + fromInt v1)
(FVal v1, FVal v2) -> FVal (v1 + v2)
(VVal x1 y1 z1, VVal x2 y2 z2) -> VVal (x1 + x2) (y1 + y2) (z1 + z2)
(RVal x1 y1 z1 s1,RVal x2 y2 z2 s2) -> RVal (x1 + x2) (y1 + y2) (z1 + z2) (s1 + s2)
(LVal l1,LVal l2) -> LVal (l1 ++ l2)
(v,LVal l2) -> LVal (v:l2)
(LVal l1, v) -> LVal (l1 ++ [v])
(SVal s1,SVal s2) -> SVal (s1 ++ s2)
_ -> error ("invalid Add operands: " ++ (show val1) ++ ", " ++ (show val2))
EvSub -> evalBinary $ \ val1 val2 -> case (val1,val2) of
(IVal i1,IVal i2) -> IVal (i1 - i2)
(IVal i1,FVal f2) -> FVal (fromInt i1 - f2)
(FVal f1,IVal i2) -> FVal (f1 - fromInt i2)
(FVal f1,FVal f2) -> FVal (f1 - f2)
(VVal x1 y1 z1,VVal x2 y2 z2) -> VVal (x1 - x2) (y1 - y2) (z1 - z2)
(RVal x1 y1 z1 s1,RVal x2 y2 z2 s2) -> RVal (x1 - x2) (y1 - y2) (z1 - z2) (s1 - s2)
_ -> error ("cannot apply - operator to " ++ (show val1) ++ " and " ++ (show val2))
EvMul -> evalBinary $ \ val1 val2 -> case (val1,val2) of
(IVal i1,IVal i2) -> IVal (i1*i2)
(IVal i1,FVal f2) -> FVal (fromInt i1 * f2)
(FVal f1,IVal i2) -> FVal (f1 * fromInt i2)
(FVal f1,FVal f2) -> FVal (f1 * f2)
(v@(VVal _ _ _),IVal i) -> let f = fromInt i in vecMulScalar v f
(v@(VVal _ _ _),FVal f) -> vecMulScalar v f
((VVal x1 y1 z1),(VVal x2 y2 z2)) -> FVal $ x1 * x2 + y1 * y2 + z1 * z2
(v@(VVal _ _ _),r@(RVal _ _ _ _)) -> rotMulVec r v
(r1@(RVal _ _ _ _),r2@(RVal _ _ _ _)) -> rotMul r1 r2
_ -> error ("cannot apply * operator to " ++ (show val1) ++ " and " ++ (show val2))
EvDiv -> evalBinary $ \ val1 val2 -> case (val1,val2) of
(IVal i1,IVal i2) -> IVal (i1 `div` i2) -- TODO: how does SL handle divide by zero?
(IVal i1,FVal f2) -> FVal (fromInt i1 / f2)
(FVal f1,IVal i2) -> FVal (f1 / fromInt i2)
(FVal f1,FVal f2) -> FVal (f1/f2)
(v@(VVal _ _ _),IVal i) -> let f = 1.0 / fromInt i in vecMulScalar v f
(v@(VVal _ _ _),FVal f) -> vecMulScalar v f
(v@(VVal _ _ _),r@(RVal _ _ _ _)) -> rotMulVec (invRot r) v
(r1@(RVal _ _ _ _),r2@(RVal _ _ _ _)) -> rotMul r1 $ invRot r2
_ -> error ("cannot apply operator to " ++ (show val1) ++ " and " ++ (show val2))
EvMod -> evalBinary $ \ val1 val2 -> case (val1,val2) of
(IVal i1,IVal i2) -> IVal (i1 `mod` i2)
(v1@(VVal _ _ _),v2@(VVal _ _ _)) -> v1 `vcross` v2
_ -> error ("cannot apply operator to " ++ (show val1) ++ " and " ++ (show val2))
EvBAnd -> evalBinary $ \ val1 val2 -> case (val1,val2) of
(IVal i1,IVal i2) -> IVal (i1 .&. i2)
_ -> error ("cannot apply operator to " ++ (show val1) ++ " and " ++ (show val2))
EvBOr -> evalBinary $ \ val1 val2 -> case (val1,val2) of
(IVal i1,IVal i2) -> IVal (i1 .|. i2)
_ -> error ("cannot apply operator to " ++ (show val1) ++ " and " ++ (show val2))
EvBXor -> evalBinary $ \ val1 val2 -> case (val1,val2) of
(IVal i1,IVal i2) -> IVal (i1 `xor` i2)
_ -> error ("cannot apply operator to " ++ (show val1) ++ " and " ++ (show val2))
EvAnd -> evalBinary $ \ val1 val2 -> case (val1,val2) of
(IVal i1,IVal i2) -> IVal (if (toBool i1 && toBool i2) then 1 else 0)
_ -> error ("cannot apply operator to " ++ (show val1) ++ " and " ++ (show val2))
EvOr -> evalBinary $ \ val1 val2 -> case (val1,val2) of
(IVal i1,IVal i2) -> IVal (if (toBool i1 || toBool i2) then 1 else 0)
_ -> error ("cannot apply operator to " ++ (show val1) ++ " and " ++ (show val2))
EvLt -> evalBinary $ \ val1 val2 -> case (val1,val2) of
(IVal i1,IVal i2) -> toLslBool $ i1 < i2
(FVal f1,FVal f2) -> toLslBool $ f1 < f2
(FVal f1,IVal i2) -> toLslBool $ f1 < fromInt i2
(IVal i1,FVal f2) -> toLslBool $ fromInt i1 < f2
_ -> error ("cannot apply operator to " ++ (show val1) ++ " and " ++ (show val2))
EvLe -> evalBinary $ \ val1 val2 -> case (val1,val2) of
(IVal i1,IVal i2) -> toLslBool $ i1 <= i2
(FVal f1,FVal f2) -> toLslBool $ f1 <= f2
(FVal f1,IVal i2) -> toLslBool $ f1 <= fromInt i2
(IVal i1,FVal f2) -> toLslBool $ fromInt i1 <= f2
_ -> error ("cannot apply operator to " ++ (show val1) ++ " and " ++ (show val2))
EvGt -> evalBinary $ \ val1 val2 -> case (val1,val2) of
(IVal i1,IVal i2) -> toLslBool $ i1 > i2
(FVal f1,FVal f2) -> toLslBool $ f1 > f2
(FVal f1,IVal i2) -> toLslBool $ f1 > fromInt i2
(IVal i1,FVal f2) -> toLslBool $ fromInt i1 > f2
_ -> error ("cannot apply operator to " ++ (show val1) ++ " and " ++ (show val2))
EvGe -> evalBinary $ \ val1 val2 -> case (val1,val2) of
(IVal i1,IVal i2) -> toLslBool $ i1 >= i2
(FVal f1,FVal f2) -> toLslBool $ f1 >= f2
(FVal f1,IVal i2) -> toLslBool $ f1 >= fromInt i2
(IVal i1,FVal f2) -> toLslBool $ fromInt i1 >= f2
_ -> error ("cannot apply operator to " ++ (show val1) ++ " and " ++ (show val2))
EvEq -> evalBinary $ \ val1 val2 -> case (val1,val2) of
(LVal l1, LVal l2) -> toLslBool $ length l1 == length l2 -- special case of LSL weirdness
(SVal s, KVal k) -> toLslBool $ s == k
(KVal k, SVal s) -> toLslBool $ k == s
(FVal f1,IVal i2) -> toLslBool $ f1 == fromInt i2
(IVal i1,FVal f2) -> toLslBool $ fromInt i1 == f2
(v1,v2) -> toLslBool $ v1 == v2
EvNe -> evalBinary $ \ val1 val2 -> case (val1,val2) of
(LVal l1, LVal l2) -> toLslBool $ length l1 /= length l2 -- special case of LSL weirdness
(SVal s, KVal k) -> toLslBool $ s /= k
(KVal k, SVal s) -> toLslBool $ k /= s
(FVal f1,IVal i2) -> toLslBool $ f1 /= fromInt i2
(IVal i1,FVal f2) -> toLslBool $ fromInt i1 /= f2
(v1,v2) -> toLslBool $ v1 /= v2
EvShiftL -> evalBinary $ \ val1 val2 -> case (val1,val2) of
(IVal i1,IVal i2) -> IVal (i1 `shiftL` i2)
_ -> error ("cannot apply operator to " ++ (show val1) ++ " and " ++ (show val2))
EvShiftR -> evalBinary $ \ val1 val2 -> case (val1,val2) of
(IVal i1,IVal i2) -> IVal (i1 `shiftR` i2)
_ -> error ("cannot apply operator to " ++ (show val1) ++ " and " ++ (show val2))
EvNot -> do
val <- popVal
pushVal $ case val of
(IVal i) -> IVal (if i == 0 then 1 else 0)
_ -> error ("cannot apply operator to " ++ (show val))
continue
EvBInv -> do
val <- popVal
pushVal $ case val of
(IVal i) -> IVal $ complement i
_ -> error ("cannot apply operator to " ++ (show val))
continue
EvNeg -> do
val <- popVal
pushVal $ case val of
(IVal i) -> IVal (-i)
(FVal f) -> FVal (-f)
(VVal x y z) -> VVal (-x) (-y) (-z)
(RVal x y z s) -> RVal (-x) (-y) (-z) (-s)
_ -> error ("cannot apply operator to " ++ (show val))
continue
EvCast t -> do
-- TODO: what are the valid typecasts?
-- TODO: what are the formats?
val <- popVal
pushVal $ case (t,val) of
(LLInteger,IVal i) -> IVal i
(LLInteger,FVal f) -> IVal (truncate f)
(LLInteger,SVal s) -> IVal (parseInt s)
-- TODO: can you cast a key to an int?
(LLFloat,FVal f) -> FVal f
(LLFloat,IVal i) -> FVal (fromInteger $ toInteger i)
(LLFloat,SVal s) -> FVal (parseFloat s)
-- TODO: can you cast a key to a float?
(LLString,v) -> toSVal v
-- TODO: can you cast anything but a string to a key?
(LLVector,SVal s) -> parseVector s
(LLRot,SVal s) -> parseRotation s
(LLList,SVal s) -> LVal [SVal s]
(LLKey,SVal s) -> KVal s
(LLKey,KVal s) -> KVal s
(LLVector, v@(VVal _ _ _)) -> v
(LLRot, v@(RVal _ _ _ _)) -> v
(LLList, LVal l) -> LVal l
continue
EvMkVec -> do
z <- popVal
y <- popVal
x <- popVal
pushVal $ VVal (toFloat x) (toFloat y) (toFloat z)
continue
EvMkRot -> do
s <- popVal
z <- popVal
y <- popVal
x <- popVal
pushVal $ RVal (toFloat x) (toFloat y) (toFloat z) (toFloat s)
continue
trueCondition (IVal i) = (i /= 0)
trueCondition (FVal f) = (f /= 0)
trueCondition (SVal s) = not (null s)
trueCondition (LVal l) = not (null l)
trueCondition v@(VVal _ _ _) = v /= llcZeroVector
trueCondition r@(RVal _ _ _ _) = r /= llcZeroRotation
trueCondition (KVal k) = k /= nullKey &&
case map tr k of
"ffffffff-ffff-ffff-ffff-ffffffffffff" -> True
_ -> False
where tr c = if c `elem` "0123456789abcdef" then 'f' else c
-- TODO: LSL also will parse hex notation for strings and floats...
parseVector s =
case [(VVal x y z,t) | ("<",t0) <- lex s,
(x,t1) <- reads t0,
(",",t2) <- lex t1,
(y,t3) <- reads t2,
(",",t4) <- lex t3,
(z,t5) <- reads t4,
(">",t) <- lex t5] of
[] -> VVal 0.0 0.0 0.0
(v,_):_ -> v
parseRotation s =
case [(RVal x y z w,t) | ("<",t0) <- lex s,
(x,t1) <- reads t0,
(",",t2) <- lex t1,
(y,t3) <- reads t2,
(",",t4) <- lex t3,
(z,t5) <- reads t4,
(",",t6) <- lex t5,
(w,t7) <- reads t6,
(">",t) <- lex t7] of
[] -> RVal 0.0 0.0 0.0 0.0
(v,_):_ -> v
toLslBool bool = IVal (if bool then 1 else 0)
evalBinary f =
do val1 <- popVal
val2 <- popVal
pushVal $ f val1 val2
return EvalIncomplete
pushUnary evalElement expr = pushElements [evalElement,EvExpr $ ctxItem expr]
pushBinary evalElement expr1 expr2 = pushElements [evalElement,EvExpr $ ctxItem expr1,EvExpr $ ctxItem expr2]
pushModBy var evalElement expr = pushElements [EvSet $ ctxVr2Vr var,evalElement,EvGet $ ctxVr2Vr var,EvExpr expr]
evalPredef' name =
do (LVal args) <- popVal
let args' = case find (\ (fname,_,_) -> name == fname) funcSigs of
Nothing -> args
Just (_,_,argTypes) -> convertArgs argTypes args
key <- getMyPrimKey
sid <- getScriptName
oid <- getObjectId
pid <- getPrimId
event <- getCurrentEvent
let scriptInfo = ScriptInfo oid pid sid key event
(evalResult,retval) <- doAction name scriptInfo args'
pushVal retval
return evalResult
where convertArgs argTypes args = zipWith convertArg argTypes args
convertArg LLFloat (IVal i) = FVal $ fromInt i
convertArg LLInteger (FVal f) = IVal $ floor f
convertArg LLKey (SVal s) = KVal s
convertArg LLString (KVal k) = SVal k
convertArg _ v = v
ctxList es = map (Ctx UnknownSourceContext) es
data ExecutionInfo = ExecutionInfo String Int FrameInfo deriving (Show)
hasActiveHandler simage handler =
case find ( \ (State ctxname _) -> curState simage == ctxItem ctxname) (states simage) of
Nothing -> False
Just (State _ handlers) -> isJust $ find (\ (Handler ctxname _ _) -> handler == ctxItem ctxname) handlers