packages feed

LslPlus 0.3.5 → 0.3.6

raw patch · 9 files changed

+62/−29 lines, 9 filesdep −ghc

Dependencies removed: ghc

Files

LslPlus.cabal view
@@ -1,5 +1,5 @@ Name:           LslPlus
-version:        0.3.5
+version:        0.3.6
 Synopsis:	    An execution and testing framework for the Linden Scripting Language (LSL)
 Description:	
 	Provides a framework for executing Linden Scripting Language scripts offline,
@@ -20,7 +20,7 @@ Extra-source-files: NOTICE
 
 Executable LslPlus
-  Build-Depends:  ghc >= 6.10, base >= 4.0 && < 4.1, haskell98, filepath >= 1.1.0.0 && < 1.2, parsec >= 2.1.0.0 && < 3,
+  Build-Depends:  base >= 4.0 && < 4.1, haskell98, filepath >= 1.1.0.0 && < 1.2, parsec >= 2.1.0.0 && < 3,
                   HaXml >= 1.19 && < 1.20, directory > 1 && < 1.1, mtl >= 1.1 && < 1.2, array >= 0.2 && < 0.3,
                   network >= 2.1 && < 2.3, random >= 1.0, containers >= 0.1 && < 0.3, old-time, utf8-string >= 0.3 && < 0.4,
                   pureMD5 >= 0.2 && < 3, bytestring >= 0.9 && < 0.10, template-haskell >= 2.3.0.0 && < 2.4, syb >= 0.1.0.0 && < 0.2.0.0
src/Language/Lsl/Internal/Constants.hs view
@@ -323,7 +323,7 @@     Constant "PARCEL_FLAG_ALLOW_CREATE_GROUP_OBJECTS" (IVal (1 `shiftL` 26)),     Constant "PARCEL_FLAG_ALLOW_CREATE_OBJECTS" (IVal (1 `shiftL` 6)),     Constant "PARCEL_FLAG_ALLOW_DAMAGE" (IVal (1 `shiftL` 5)),-    Constant "PARCEL_FLAG_ALLOW_FLY" (IVal 0),+    Constant "PARCEL_FLAG_ALLOW_FLY" (IVal 1),     Constant "PARCEL_FLAG_ALLOW_GROUP_OBJECT_ENTRY" (IVal (1 `shiftL` 28)),     Constant "PARCEL_FLAG_ALLOW_GROUP_SCRIPTS" (IVal (1 `shiftL` 25)),     Constant "PARCEL_FLAG_ALLOW_LANDMARK" (IVal (1 `shiftL` 3)),@@ -479,7 +479,7 @@     Constant "PSYS_SRC_TEXTURE" (IVal 12),     Constant "PUBLIC_CHANNEL" (IVal 0),     Constant "RAD_TO_DEG" (FVal 57.29578),-    Constant "REGION_FLAG_ALLOW_DAMAGE" (IVal 0),+    Constant "REGION_FLAG_ALLOW_DAMAGE" (IVal 1),     Constant "REGION_FLAG_ALLOW_DIRECT_TELEPORT" (IVal (1 `shiftL` 20)),     Constant "REGION_FLAG_BLOCK_FLY" (IVal (1 `shiftL` 19)),     Constant "REGION_FLAG_BLOCK_TERRAFORM" (IVal (1 `shiftL` 6)),
src/Language/Lsl/Internal/Exec.hs view
@@ -1042,12 +1042,12 @@                        -- 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
+                       (LLList,v) -> LVal [v]
                     continue
                EvMkVec -> do
                    z <- popVal
src/Language/Lsl/Internal/InternalLLFuncs.hs view
@@ -617,7 +617,7 @@     let i1 = map charToBits $ stripPadChars s1
         i2 = map charToBits $ stripPadChars s2
         n = length i2
-        i3 = zipWith (\ v i -> v `xor` (i2 !! (i `mod` n))) i1 [0..]
+        i3 = if null i2 then i1 else zipWith (\ v i -> v `xor` (i2 !! (i `mod` n))) i1 [0..]
     in continueWith $ SVal $ map (base64chars !!) i3
 
 -- test strings s1 = YWJjZGVm, s2 = eHl6 => GRsZHBwc
@@ -629,7 +629,7 @@     let s1' = map fromEnum $ decodeB64 s1
         s2' = map fromEnum $ decodeB64 s2
         n = length s2'
-        s3 = zipWith (\ v i -> v `xor` (s2' !! (i `mod` n))) s1' [0..]
+        s3 = if null s2' then s1' else zipWith (\ v i -> v `xor` (s2' !! (i `mod` n))) s1' [0..]
     in continueWith $ SVal $ encodeB64 (map toEnum s3)
 llBase64ToString _ [SVal s] = continueWith $ SVal $ map mkPrintable $ decodeB64 s
src/Language/Lsl/Internal/Optimize.hs view
@@ -16,6 +16,7 @@ import Debug.Trace
 
 import Language.Lsl.Parse
+import Language.Lsl.Render
 import Language.Lsl.Internal.Constants(allConstants,Constant(..),findConstVal)
 import Language.Lsl.Internal.FuncSigs(funcSigs)
 import Language.Lsl.Internal.InternalLLFuncs(internalLLFuncs,internalLLFuncNames)
@@ -114,6 +115,10 @@ nullCtx :: a -> Ctx a              
 nullCtx = Ctx Nothing 
 
+sminsert k v (m:ms) = M.insert k v m : ms
+
+unionall = foldl' M.union M.empty
+
 newtype FunctionFacts = FunctionFacts { isPureFunction :: Bool } deriving (Show)
 
 data OptimizerState = OptimizerState { 
@@ -124,8 +129,8 @@     optVerbotenNames :: !(Set.Set String),
     optLocals :: ![[String]],
     optInlinerRenames :: ![M.Map String String], -- names that must be renamed in the 'destination' function/handler
-    optRenames :: !(M.Map String String), -- names that must be renamed in the function to-be-inlined
-    optRewrites :: !(M.Map String Expr),
+    optRenames :: ![M.Map String String], -- names that must be renamed in the function to-be-inlined
+    optRewrites :: ![M.Map String Expr],
     optRetVar :: !(Maybe String),
     optStmts :: ![[Ctx Statement]] } deriving Show
     
@@ -142,8 +147,8 @@     optVerbotenNames = Set.empty,
     optLocals = [],
     optInlinerRenames = [],
-    optRenames = M.empty,
-    optRewrites = M.empty,
+    optRenames = [M.empty],
+    optRewrites = [M.empty],
     optRetVar = Nothing,
     optStmts = [] }
     
@@ -157,7 +162,7 @@ refreshOState :: OState ()
 refreshOState = do
     st <- get
-    put $ st { optRenames = M.empty, optRetVar = Nothing, optStmts = [] }
+    put $ st { optRenames = [M.empty], optRetVar = Nothing, optStmts = [] }
 
 pushLocal s = do
     st <- get
@@ -183,13 +188,27 @@     let s = optVerbotenNames st
     put st { optVerbotenNames = (Set.insert name s) }
     
+pushRewriteInfo = get >>= \ st -> put st { optRenames = M.empty:(optRenames st), optRewrites = M.empty:(optRewrites st) }
+
+withMoreRewriteInfo action = do
+    rns <- get >>= return . optRenames
+    rws <- get >>= return . optRewrites
+    pushRewriteInfo
+    v <- action
+    get >>= \ st -> put st { optRenames = rns, optRewrites = rws }
+    return v
+
 addRename s s' = do
     st <- get
-    put st { optRenames = M.insert s s' (optRenames st) }
+    put st { optRenames = sminsert s s' (optRenames st) }
     
+addRewrite s e = do
+    st <- get
+    put st { optRewrites = sminsert s e (optRewrites st) }
+    
 rewriteLabel s = do
     renames <- get >>= return . optRenames
-    return $ maybe s id (M.lookup s renames)
+    return $ maybe s id (M.lookup s $ unionall renames)
 
 renameToNew s = do
    verboten <- isVerboten s
@@ -240,7 +259,7 @@    return (Var s' t)
    
 getRewriteInfo :: OState (M.Map String String, M.Map String Expr)
-getRewriteInfo = get >>= ( \ st -> return (optRenames st, optRewrites st))
+getRewriteInfo = get >>= ( \ st -> return (unionall $ optRenames st, unionall $ optRewrites st))
 
 isVerboten s = do
     verbotenNames <- get >>= return . optVerbotenNames
@@ -252,11 +271,11 @@     [Ctx Expr] -> -- the arguments to the call
     OState ([Ctx Statement],[Ctx Statement]) -- 
 inlineProc (Ctx c (Func fd ss)) args = do
-        endLabel <- mkName "end"
-        parmVars <- mkParmVars ss (zip ps args)
-        stmts <- inlineStmts endLabel (map ctxItem ss) >>= return . map nullCtx >>= return . withoutFinalJumpTo endLabel
-        return (if jumpsTo endLabel stmts == 0 then [] else [nullCtx $ Label endLabel], parmVars ++ stmts)
-               -- simplify $ nullCtx (Compound (parmVars ++ stmts)))
+        withMoreRewriteInfo $ do
+            endLabel <- mkName "end"
+            parmVars <- mkParmVars ss (zip ps args)
+            stmts <- inlineStmts endLabel (map ctxItem ss) >>= return . map nullCtx >>= return . withoutFinalJumpTo endLabel
+            return (if jumpsTo endLabel stmts == 0 then [] else [nullCtx $ Label endLabel], parmVars ++ stmts)
     where ps = funcParms fd
     
 nullify :: Data a => a -> a
@@ -272,10 +291,9 @@     if isRelativelyPure locals funFacts arg && 
        (staticComplexity arg < 2 || usageCount nm ss == 1) && not (nm `isModifiedIn` ss) && (simpleRef arg || nm `isUsedOnlyWholeIn` ss)
         then do
-            st <- get
             case arg of
                 (Ctx _ (Get (cnm,All))) -> addRename nm (ctxItem cnm)
-                _ -> put st { optRewrites = M.insert (varName v) (ctxItem arg) (optRewrites st) }
+                _ -> addRewrite (varName v) (ctxItem arg)
             return []
         else do
             v' <- renameVar v
@@ -300,6 +318,10 @@     (endStmts,stmts) <- inlineProc f args
     return (stmts ++ endStmts)
 
+--trS s sts = trace (s ++ " {\n" ++ renderStatements 1 (map nullCtx sts) "" ++ "}\n") sts
+
+--inlineStmts' s ss = inlineStmts s (trS "in->" ss) >>= return . (trS "out->")
+
 inlineStmts :: String -> [Statement] -> OState [Statement]
 inlineStmts _ [] = return []
 inlineStmts endLabel (NullStmt:NullStmt:stmts) = inlineStmts endLabel (NullStmt:stmts)
@@ -326,7 +348,7 @@     -- must rename the label BEFORE rewriting the rest of the statements
     s' <- renameToNew s
     stmts' <- inlineStmts endLabel stmts
-    return (Label s':stmts)
+    return (Label s':stmts')
 inlineStmts endLabel (Jump s:stmts) = do
     -- must process the rest of the statements BEFORE rewriting the Jump
     stmts' <- inlineStmts endLabel stmts
@@ -522,8 +544,6 @@ 
 inlineCall c@(Call (Ctx _ nm) es) = do
     fs <- get >>= return . optAllFuncs
-    tmp <- get >>= return . optInlinerRenames
-    tmp1 <- get >>= return . optRenames
     case M.lookup nm fs of
         Nothing -> return c
         Just f -> do
@@ -1005,6 +1025,7 @@ simplifyS (If (Ctx _ (IntLit _)) stmt _) = return stmt
 simplifyS (If (Ctx _ (FloatLit 0)) _ stmt) = return stmt
 simplifyS (If (Ctx _ (FloatLit _)) stmt _) = return  stmt
+simplifyS (Do (Ctx _ (Get _))) = return NullStmt
 simplifyS s = return s
 
 toFloatLit (Ctx c (IntLit i))  = (Ctx c (FloatLit $ fromIntegral i))
src/Language/Lsl/Render.hs view
@@ -108,6 +108,10 @@     renderString "if (" . renderCtxExpr expr . renderChar ')' . 
         (case stmt1 of
              NullStmt -> renderString ";\n"
+             If expr (Compound _) _ -> renderStatement True n stmt1
+             If expr _ NullStmt -> case stmt2 of
+                 NullStmt -> renderStatement True n stmt1
+                 _ -> renderStatement True n (Compound [Ctx Nothing stmt1])
              _ -> renderStatement True n stmt1) .
         case stmt2 of 
             NullStmt -> blank
src/Language/Lsl/Sim.hs view
@@ -168,7 +168,7 @@     lift $ putWorldEvent 0 (SensorEvent (pk,sn) name key etype range arc Nothing) >> continueWith VoidVal
 llSensorRepeat info@(ScriptInfo _ _ sn pk _) [SVal name, KVal key, IVal etype, FVal range, FVal arc, FVal interval] =
     let interval' = if interval < 0 then 0 else interval in
-        lift $ putWorldEvent 0 (SensorEvent (pk,sn) name key etype range arc (Just interval')) >> continueWith VoidVal
+        lift $ putWorldEvent interval (SensorEvent (pk,sn) name key etype range arc (Just interval')) >> continueWith VoidVal
 llSensorRemove info@(ScriptInfo _ _ sn pk _) [] =
     do q <- lift getWQueue
        lift $ setWQueue [ qentry | qentry@(_,event) <- q, not (isSensorEvent event) || sensorAddress event /= (pk,sn)]
src/Language/Lsl/Syntax.hs view
@@ -737,7 +737,12 @@             Nothing -> return ()
             Just t' -> do
                 (rtype,_) <- get'vsEntryPointInfo
-                when (t' /= rtype && not (all (`elem` [LLString,LLKey]) [t',rtype])) (vsmAddErr (ctx,"inappropriate return type for function/handler"))
+                case (t',rtype) of
+                   (LLString,LLKey) -> return ()
+                   (LLKey,LLString) -> return ()
+                   (LLInteger,LLFloat) -> return ()
+                   (x,y) | x == y -> return ()
+                         | otherwise -> (vsmAddErr (ctx,"inappropriate return type for function/handler"))
         put'vsBranchReturns True
         return True
 compileStatement (Ctx ctx (StateChange name)) = do
@@ -773,7 +778,10 @@                       (LLString,LLVector),(LLVector,LLString),
                       (LLString,LLKey),(LLKey,LLString),
                       (LLRot,LLString),(LLString,LLRot),
-                      (LLList,LLString),(LLString,LLList)]
+                      (LLList,LLString),(LLString,LLList),
+                      (LLFloat,LLList),(LLInteger,LLList),
+                      (LLVector,LLList),(LLRot,LLList),
+                      (LLKey,LLList)]
 
 compileCtxExpr :: Ctx Expr -> VState (Maybe LSLType)
 compileCtxExpr (Ctx ctx (Cast t expr)) =
src/LslPlus.hs view
@@ -12,7 +12,7 @@ import System
 import System.Exit
 
-version="0.3.5"
+version="0.3.6"
 usage progName = "Usage: " ++ progName ++ " [Version|MetaData|Compiler|ExpressionHandler|SimMetaData|SystemTester|UnitTester]"
 main = do
     progName <- getProgName