diff --git a/LslPlus.cabal b/LslPlus.cabal --- a/LslPlus.cabal +++ b/LslPlus.cabal @@ -1,34 +1,85 @@ Name: LslPlus -version: 0.1.4 -Synopsis: An execution and testing framework for the Linden Scripting Language (LSL) +version: 0.2.0 +Synopsis: An execution and testing framework for the Linden Scripting Language (LSL) Description: Provides a framework for executing Linden Scripting Language scripts offline, - i.e. outside a Second Life® simulator. The primary product is the LslPlus executable, + i.e. outside a Second Life® simulator. The product is the LslPlus executable, which works in cooperation with the LSL Plus Eclipse plugin (the executable is not - much use standalone). It also provides a library, which includes a parser and - corresponding quasiquoter, a unit test framework for LSL, and a simulator for running - scripts. + much use standalone). Cabal-Version: >= 1.5 Homepage: http:/lslplus.sourceforge.net/ License: BSD3 License-file: LICENSE -Category: Language -Copyright: Copyright (c) Robert Greayer 2008. -Author: Robert Greayer -Maintainer: robgreayer@yahoo.com -Stability: experimental +Category: Language +Copyright: Copyright (c) Robert Greayer 2008. +Author: Robert Greayer +Maintainer: Robert Greayer +Stability: experimental Build-Type: Simple Tested-With: GHC ==6.10.1 -Extra-source-files: NOTICE, noqqsrc/Language/Lsl/Internal/BuiltInModules.hs +Extra-source-files: NOTICE -Library +-- Library +-- Build-Depends: ghc >= 6.10, 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 +-- Exposed-Modules: Language.Lsl.Syntax, Language.Lsl.Parse, Language.Lsl.QQ, Language.Lsl.Sim +-- Language.Lsl.WorldDef, Language.Lsl.UnitTest, Language.Lsl.UnitTestEnv, Language.Lsl.Render +-- Other-modules: +-- Language.Lsl.Internal.Animation +-- Language.Lsl.Internal.AvEvents +-- Language.Lsl.Internal.Breakpoint +-- Language.Lsl.Internal.BreakpointsDeserialize +-- Language.Lsl.Internal.BuiltInModules +-- Language.Lsl.Internal.CodeHelper +-- Language.Lsl.Internal.Compiler +-- Language.Lsl.Internal.Constants +-- Language.Lsl.Internal.DOMProcessing +-- Language.Lsl.Internal.DOMSourceDescriptor +-- Language.Lsl.Internal.DOMUnitTestDescriptor +-- Language.Lsl.Internal.Evaluation +-- Language.Lsl.Internal.EventSigs +-- Language.Lsl.Internal.Exec +-- Language.Lsl.Internal.ExecInfo +-- Language.Lsl.Internal.ExpressionHandler +-- Language.Lsl.Internal.FuncSigs +-- Language.Lsl.Internal.InternalLLFuncs +-- Language.Lsl.Internal.Key +-- Language.Lsl.Internal.Load +-- Language.Lsl.Internal.Log +-- Language.Lsl.Internal.Math +-- Language.Lsl.Internal.MetaData +-- Language.Lsl.Internal.NumberParsing +-- Language.Lsl.Internal.Optimize +-- Language.Lsl.Internal.Physics +-- Language.Lsl.Internal.SHA1 +-- Language.Lsl.Internal.SimMetaData +-- Language.Lsl.Internal.SystemTester +-- Language.Lsl.Internal.TestResult +-- Language.Lsl.Internal.Type +-- Language.Lsl.Internal.UnitTester +-- Language.Lsl.Internal.Util +-- Language.Lsl.Internal.WorldState +-- Language.Lsl.Internal.XmlCreate +-- Hs-Source-Dirs: src, qqsrc +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, 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 - Exposed-Modules: Language.Lsl.Syntax, Language.Lsl.Parse, Language.Lsl.QQ, Language.Lsl.Sim - Language.Lsl.WorldDef, Language.Lsl.UnitTest, Language.Lsl.UnitTestEnv, Language.Lsl.Render + Main-Is: LslPlus.hs + Hs-Source-Dirs: src Other-modules: + Language.Lsl.Syntax + Language.Lsl.Parse + Language.Lsl.QQ + Language.Lsl.Sim + Language.Lsl.WorldDef + Language.Lsl.UnitTest + Language.Lsl.UnitTestEnv + Language.Lsl.Render + Language.Lsl.Internal.AccessGenerator Language.Lsl.Internal.Animation Language.Lsl.Internal.AvEvents Language.Lsl.Internal.Breakpoint @@ -64,13 +115,4 @@ Language.Lsl.Internal.Util Language.Lsl.Internal.WorldState Language.Lsl.Internal.XmlCreate - Hs-Source-Dirs: src, qqsrc -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, - 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 - Main-Is: LslPlus.hs - Hs-Source-Dirs: src, qqsrc Ghc-Options: -fwarn-unused-imports - diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,7 +1,8 @@ import Distribution.Simple -import Distribution.Simple.Haddock (haddock, hscolour) -import Distribution.PackageDescription +-- import Distribution.Simple.Haddock (haddock, hscolour) +-- import Distribution.PackageDescription -main = defaultMainWithHooks (simpleUserHooks { - preHaddock = \_ _ -> return (Just $ emptyBuildInfo { hsSourceDirs = ["noqqsrc"]},[]) }) +main = defaultMain +-- main = defaultMainWithHooks (simpleUserHooks { +-- preHaddock = \_ _ -> return (Just $ emptyBuildInfo { hsSourceDirs = ["noqqsrc"]},[]) }) diff --git a/noqqsrc/Language/Lsl/Internal/BuiltInModules.hs b/noqqsrc/Language/Lsl/Internal/BuiltInModules.hs deleted file mode 100644 --- a/noqqsrc/Language/Lsl/Internal/BuiltInModules.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Language.Lsl.Internal.BuiltInModules(avEventGen) where - -import Language.Lsl.Syntax - -avEventGen :: (String,LModule) -avEventGen = ("$avEventGen", undefined) diff --git a/qqsrc/Language/Lsl/Internal/BuiltInModules.hs b/qqsrc/Language/Lsl/Internal/BuiltInModules.hs deleted file mode 100644 --- a/qqsrc/Language/Lsl/Internal/BuiltInModules.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# OPTIONS_GHC -XQuasiQuotes #-} -module Language.Lsl.Internal.BuiltInModules(avEventGen) where - -import Language.Lsl.Syntax -import Language.Lsl.QQ(lslm) - -avEventGenAST = [$lslm|$module - string mkTouch(string primKey, float duration) { - return "AvatarTouch {avatarTouchPrimKey = \"" + primKey + "\", avatarTouchDuration = " + (string) duration + "}"; - } - string mkWhisper(integer chan, string message) { - return "AvatarWhisper { avatarChatChannel = " + (string)chan + ", avatarChatMessage = \"" + message + "\"}"; - } - string mkSay(integer chan, string message) { - return "AvatarSay { avatarChatChannel = " + (string)chan + ", avatarChatMessage = \"" + message + "\"}"; - } - string mkShout(integer chan, string message) { - return "AvatarShout { avatarChatChannel = " + (string)chan + ", avatarChatMessage = \"" + message + "\"}"; - } - string mkPay(string primKey, integer amount) { - return "AvatarPay { avatarPayPrimKey = \"" + primKey + "\", avatarPayAmount = " + (string) amount + "}"; - } - string mkControl(integer newControlBits) { - return "AvatarControl { avatarNewControlBits = " + (string) newControlBits + "}"; - } - |] - -avEventGen = ("$avEventGen", avEventGenAST) diff --git a/src/Language/Lsl/Internal/AccessGenerator.hs b/src/Language/Lsl/Internal/AccessGenerator.hs new file mode 100644 --- /dev/null +++ b/src/Language/Lsl/Internal/AccessGenerator.hs @@ -0,0 +1,66 @@ +{-# OPTIONS_GHC -XTemplateHaskell #-} +module Language.Lsl.Internal.AccessGenerator(genAccessorsForType,genMAccessorsForType) where + +import Language.Haskell.TH +import Control.Monad.State + +genAccessors (ConT nm) = genAccessorsForType nm +genAccessors _ = fail "can't generate accessors for specified type" + +genAccessorsForType nm = do + info <- reify nm + case info of + TyConI d -> generateAccessorsForDec d + _ -> fail $ "can't generate accessors for specified name: " ++ show nm + +generateAccessorsForDec (DataD _ _ _ [con] _) = generateAccessorsForCon con +generateAccessorsForDec (DataD _ _ _ _ _) = fail "can't generate accessors for data type with multiple constructors" +generateAccessorsForDec _ = fail "can only generate accessors for 'data' types (not even newtypes)" + +generateAccessorsForCon (RecC _ vs) = generateAccessorsForSelectors vs +generateAccessorsForCon _ = fail "can only generate accessors for constructors with record selectors (and not quantified constructors)" + +generateAccessorsForSelectors vs = mapM generateAccessorForSelector vs +generateAccessorForSelector (nm,_,_) = + let nm' = mkName ("set'" ++ nameBase nm) in do + nm0 <- newName "x" + nm1 <- newName "y" + return (FunD nm' [Clause [VarP nm0, VarP nm1] (NormalB (RecUpdE (VarE nm0) [(nm,VarE nm1)])) []]) + +genMAccessors (ConT nm) = genAccessorsForType nm +genMAccessors _ = fail "can't generate accessors for specified type" + +genMAccessorsForType nm = do + info <- reify nm + case info of + TyConI d -> generateMAccessorsForDec d + _ -> fail $ "can't generate accessors for specified name: " ++ show nm + +generateMAccessorsForDec (DataD _ _ _ [con] _) = generateMAccessorsForCon con +generateMAccessorsForDec (DataD _ _ _ _ _) = fail "can't generate accessors for data type with multiple constructors" +generateMAccessorsForDec _ = fail "can only generate accessors for 'data' types (not even newtypes)" + +generateMAccessorsForCon (RecC _ vs) = generateMAccessorsForSelectors vs +generateMAccessorsForCon _ = fail "can only generate accessors for constructors with record selectors (and not quantified constructors)" + +generateMAccessorsForSelectors vs = + mapM generateMAccessorForSelector vs >>= return . concat + +generateMAccessorForSelector (nm,_,_) = + let nmPut' = mkName ("put'" ++ nameBase nm) + nmGet' = mkName ("get'" ++ nameBase nm) + nmCompose = '(.) + nmBind = '(>>= ) + nmGet = 'get + nmPut = 'put + nmReturn = 'return + in do + nm0 <- newName "x" + nm1 <- newName "s" + return [(FunD nmGet' [Clause [] (NormalB (AppE (AppE (VarE nmBind) (VarE nmGet)) (AppE (AppE (VarE nmCompose) (VarE nmReturn)) (VarE nm)))) []]), + (FunD nmPut' [Clause [VarP nm0] + (NormalB + -- get >>= \ s -> put (s { nm = nm0 }) + (AppE (AppE (VarE nmBind) (VarE nmGet)) (LamE [VarP nm1] (AppE (VarE nmPut) (RecUpdE (VarE nm1) [(nm,VarE nm0)])))) + ) []])] + diff --git a/src/Language/Lsl/Internal/BuiltInModules.hs b/src/Language/Lsl/Internal/BuiltInModules.hs new file mode 100644 --- /dev/null +++ b/src/Language/Lsl/Internal/BuiltInModules.hs @@ -0,0 +1,28 @@ +{-# OPTIONS_GHC -XQuasiQuotes #-} +module Language.Lsl.Internal.BuiltInModules(avEventGen) where + +import Language.Lsl.Syntax +import Language.Lsl.QQ(lslm) + +avEventGenAST = [$lslm|$module + string mkTouch(string primKey, float duration) { + return "AvatarTouch {avatarTouchPrimKey = \"" + primKey + "\", avatarTouchDuration = " + (string) duration + "}"; + } + string mkWhisper(integer chan, string message) { + return "AvatarWhisper { avatarChatChannel = " + (string)chan + ", avatarChatMessage = \"" + message + "\"}"; + } + string mkSay(integer chan, string message) { + return "AvatarSay { avatarChatChannel = " + (string)chan + ", avatarChatMessage = \"" + message + "\"}"; + } + string mkShout(integer chan, string message) { + return "AvatarShout { avatarChatChannel = " + (string)chan + ", avatarChatMessage = \"" + message + "\"}"; + } + string mkPay(string primKey, integer amount) { + return "AvatarPay { avatarPayPrimKey = \"" + primKey + "\", avatarPayAmount = " + (string) amount + "}"; + } + string mkControl(integer newControlBits) { + return "AvatarControl { avatarNewControlBits = " + (string) newControlBits + "}"; + } + |] + +avEventGen = ("$avEventGen", avEventGenAST) diff --git a/src/Language/Lsl/Internal/Compiler.hs b/src/Language/Lsl/Internal/Compiler.hs --- a/src/Language/Lsl/Internal/Compiler.hs +++ b/src/Language/Lsl/Internal/Compiler.hs @@ -38,6 +38,11 @@ do augLib <- loadModules moduleInfo scripts <- loadScripts (libFromAugLib augLib) scriptInfo return (augLib,scripts) +-- compile' :: ([(String,String)],[(String,String)]) -> IO (AugmentedLibrary,[(String,Validity CompiledLSLScript)]) +-- compile' (moduleInfo,scriptInfo) = +-- do augLib <- loadModules' moduleInfo +-- scripts <- loadScripts' (libFromAugLib augLib) scriptInfo +-- return (augLib,scripts) formatCompilationSummary :: (AugmentedLibrary,[(String,Validity CompiledLSLScript)]) -> String formatCompilationSummary (augLib, scripts) = @@ -49,7 +54,7 @@ emit "item" ([emit "name" [showString name]] ++ case result of - Left err -> [formatErr err] + Left errs -> [emit "status" [emit "ok" [showString "false"], emit "errs" (map formatErr errs)]] Right (CompiledLSLScript globals funcs states) -> [emit "status" [emit "ok" [showString "true"]], emit "entryPoints" (map emitFunc funcs ++ concatMap stateEntryPointEmitters states), @@ -61,7 +66,7 @@ emit "item" ([emit "name" [showString name]] ++ case result of - Left err -> [formatErr err] + Left errs -> [emit "status" [emit "ok" [showString "false"], emit "errs" (map formatErr errs)]] Right (LModule globdefs freevars,(globals,_)) -> [emit "status" [emit "ok" [showString "true"]], emit "entryPoints" (map emitFunc (funcs globdefs)), @@ -94,7 +99,7 @@ emitParam var = emit "param" [emit "name" [showString $ varName var], emit "type" [showString $ lslTypeString $ varType var]] formatErr (ctx,msg) = - emit "status" [emit "ok" [showString "false"] , formatCtx ctx , emit "msg" [showString (xmlEscape msg)]] + emit "itemError" [formatCtx ctx , emit "msg" [showString (xmlEscape msg)]] formatCtx UnknownSourceContext = id formatCtx (TextLocation { textLine0 = l0, textColumn0 = c0, textLine1 = l1, textColumn1 = c1, textName = n }) = @@ -137,4 +142,4 @@ do exists <- doesFileExist outpath when exists $ removeFile outpath where outpath = replaceExtension path ".lsl" - + diff --git a/src/Language/Lsl/Internal/Exec.hs b/src/Language/Lsl/Internal/Exec.hs --- a/src/Language/Lsl/Internal/Exec.hs +++ b/src/Language/Lsl/Internal/Exec.hs @@ -892,6 +892,8 @@ (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 + (IVal i,v@(VVal _ _ _)) -> let f = fromInt i in vecMulScalar v f + (FVal f,v@(VVal _ _ _)) -> 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 @@ -1102,4 +1104,4 @@ 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 + Just (State _ handlers) -> isJust $ find (\ (Handler ctxname _ _) -> handler == ctxItem ctxname) handlers diff --git a/src/Language/Lsl/Internal/Load.hs b/src/Language/Lsl/Internal/Load.hs --- a/src/Language/Lsl/Internal/Load.hs +++ b/src/Language/Lsl/Internal/Load.hs @@ -5,7 +5,7 @@ import Control.Exception(SomeException(..),tryJust) import Control.Monad.Error(liftIO) import Language.Lsl.Internal.BuiltInModules(avEventGen) -import Language.Lsl.Syntax(validLSLScript,validLibrary,SourceContext(..)) +import Language.Lsl.Syntax(SourceContext(..),compileLSLScript',compileLibrary) import Language.Lsl.Parse(parseModule, parseScript) parseFiles p files = @@ -20,15 +20,27 @@ loadModules files = do parseResults <- parseFiles parseModule files let (bad,ok) = splitResults parseResults - let augLib = validLibrary (avEventGen:ok) - return (augLib ++ (map (\ (n,err) -> (n,Left err)) bad)) - --return (validated ++ (map (\ (n,err) -> (n,Left err)) bad)) + let augLib = compileLibrary (avEventGen:ok) + return (augLib ++ (map (\ (n,err) -> (n,Left [err])) bad)) +-- loadModules' files = +-- do parseResults <- parseFiles parseModule files +-- let (bad,ok) = splitResults parseResults +-- let augLib = validLibrary (avEventGen:ok) +-- return (augLib ++ (map (\ (n,err) -> (n,Left [err])) bad)) +-- --return (validated ++ (map (\ (n,err) -> (n,Left err)) bad)) + loadScripts library files = do parseResults <- parseFiles parseScript files let (bad,ok) = splitResults parseResults - return $ (map (\ (n,script) -> (n,validLSLScript library script)) ok) ++ - (map (\ (n,err) -> (n,Left err)) bad) + return $ (map (\ (n,script) -> (n,compileLSLScript' library script)) ok) ++ + (map (\ (n,err) -> (n,Left [err])) bad) + +-- loadScripts' library files = +-- do parseResults <- parseFiles parseScript files +-- let (bad,ok) = splitResults parseResults +-- return $ (map (\ (n,script) -> (n,validLSLScript library script)) ok) ++ +-- (map (\ (n,err) -> (n,Left [err])) bad) splitResults [] = ([],[]) splitResults ((name,Left err):xs) = diff --git a/src/Language/Lsl/Parse.hs b/src/Language/Lsl/Parse.hs --- a/src/Language/Lsl/Parse.hs +++ b/src/Language/Lsl/Parse.hs @@ -142,12 +142,23 @@ combineExprs e [] = e combineExprs e0 ((p0,p1,op,e1):rest) = combineExprs (op p0 p1 e0 e1) rest +isFollowedBy p = do + lookAhead p + return () + +reservedOp' name = + lexeme $ try $ + do{ string name + ; ( (isFollowedBy (char '-')) <|> notFollowedBy (P.opLetter lslStyle)) ("end of " ++ show name) + } + opmatch s f = (reservedOp s >> return f) -op0 = ((opmatch "*" mulop) <|> (opmatch "/" divop) <|> (opmatch "%" modop)) "operator" -op1 = ((opmatch "+" addop) <|> (opmatch "-" subop)) "operator" -op2 = ((opmatch "<<" shiftlop) <|> (opmatch ">>" shiftrop)) "operator" -op3 = (choice [opmatch "<" ltop, opmatch "<=" leop, opmatch ">" gtop, opmatch ">=" geop]) "operator" -op4 = ((opmatch "==" eqop) <|> (opmatch "!=" neop)) "operator" +opmatch' s f = (reservedOp' s >> return f) +op0 = ((opmatch' "*" mulop) <|> (opmatch' "/" divop) <|> (opmatch' "%" modop)) "operator" +op1 = ((opmatch' "+" addop) <|> (opmatch "-" subop)) "operator" +op2 = ((opmatch' "<<" shiftlop) <|> (opmatch' ">>" shiftrop)) "operator" +op3 = (choice [opmatch' "<" ltop, opmatch' "<=" leop, opmatch' ">" gtop, opmatch' ">=" geop]) "operator" +op4 = ((opmatch' "==" eqop) <|> (opmatch' "!=" neop)) "operator" opAndExpr opf ef = do pos0 <- getPosition op <- opf @@ -166,11 +177,11 @@ rest <- (try (many (try (opAndExpr op3 shiftExpr))) <|> return []) return $ combineExprs e0 rest eqExpr = exprChain op4 relExpr -bandExpr = exprChain (opmatch "&" bandop "operator") eqExpr -xorExpr = exprChain (opmatch "^" xorop "operator") bandExpr -borExpr = exprChain (opmatch "|" borop "operator") xorExpr -andExpr = exprChain (opmatch "&&" andop "operator") borExpr -orExpr = exprChain (opmatch "||" orop "operator") andExpr +bandExpr = exprChain (opmatch' "&" bandop "operator") eqExpr +xorExpr = exprChain (opmatch' "^" xorop "operator") bandExpr +borExpr = exprChain (opmatch' "|" borop "operator") xorExpr +andExpr = exprChain (opmatch' "&&" andop "operator") borExpr +orExpr = exprChain (opmatch' "||" orop "operator") andExpr bop op pos0 pos1 e0 e1 = let ctx = combineContexts (srcCtx e0, pos0, pos1, srcCtx e1) in Ctx ctx $ op e0 e1 @@ -207,12 +218,12 @@ assignment = ctxify $ do v <- var - op <- choice [reservedOp "+=" >> (return $ IncBy), - reservedOp "-=" >> (return $ DecBy), - reservedOp "*=" >> (return $ MulBy), - reservedOp "/=" >> (return $ DivBy), - reservedOp "%=" >> (return $ ModBy), - reservedOp "=" >> (return $ Set)] "assignment operator" + op <- choice [reservedOp' "+=" >> (return $ IncBy), + reservedOp' "-=" >> (return $ DecBy), + reservedOp' "*=" >> (return $ MulBy), + reservedOp' "/=" >> (return $ DivBy), + reservedOp' "%=" >> (return $ ModBy), + reservedOp' "=" >> (return $ Set)] "assignment operator" e <- expr return $ op v e @@ -328,8 +339,8 @@ postfixExpr = ctxify $ do v <- var - f <- choice [reservedOp "++" >> return PostInc, - reservedOp "--" >> return PostDec] "postfix operator" + f <- choice [reservedOp' "++" >> return PostInc, + reservedOp' "--" >> return PostDec] "postfix operator" return $ f v prefixExpr = ctxify $ do f <- choice [reservedOp "--" >> return (PreDec), @@ -373,7 +384,7 @@ declStatement = do t <- typeName id <- identifier - rest <- (option Nothing (reservedOp "=" >> expr >>= return . Just)) + rest <- (option Nothing (reservedOp' "=" >> expr >>= return . Just)) semi return $ Decl (Var id t) rest @@ -497,7 +508,7 @@ func t id = do ps <- parens params stmts <- braces statements return $ GF $ Func (FuncDec id t ps) stmts -gvar ctx t (Ctx _ id) = do mexpr <- option Nothing (reservedOp "=" >> expr >>= return . Just) +gvar ctx t (Ctx _ id) = do mexpr <- option Nothing (reservedOp' "=" >> expr >>= return . Just) semi return $ GV (Ctx ctx (Var id t)) mexpr -------------------------------------------------------------- @@ -566,21 +577,21 @@ Left err -> Left (snd (fromParseError err)) Right x -> Right x --- | Parse an LSL script into its syntax tree. +-- | Parse an LSL script into its syntax tree. parseScriptFromString :: String -> Either String LSLScript parseScriptFromString s = parseFromString lslParser s --- | Parse an LSL (Plus) module into its syntax tree. +-- | Parse an LSL (Plus) module into its syntax tree. parseModuleFromString :: String -> Either String LModule parseModuleFromString s = parseFromString moduleParser s --- | Parse an LSL script, with possible antiquotations, into its syntax tree. +-- | Parse an LSL script, with possible antiquotations, into its syntax tree. parseScriptFromStringAQ :: String -> Either ParseError LSLScript parseScriptFromStringAQ s = runParser lslParser True "" s --- | Parse an LSL (Plus) module, with possible antiquotations, into its syntax tree. +-- | Parse an LSL (Plus) module, with possible antiquotations, into its syntax tree. parseModuleFromStringAQ :: String -> Either ParseError LModule parseModuleFromStringAQ s = runParser moduleParser True "" s -parseModule :: (MonadIO m) => SourceName -> m (Either (SourceContext,String) LModule) +parseModule :: (MonadIO m) => SourceName -> m (Either (SourceContext,String) LModule) parseModule file = parseFile moduleParser file parseScript file = parseFile lslParser file diff --git a/src/Language/Lsl/Render.hs b/src/Language/Lsl/Render.hs --- a/src/Language/Lsl/Render.hs +++ b/src/Language/Lsl/Render.hs @@ -2,11 +2,11 @@ import Data.List(foldl',intersperse) import Language.Lsl.Syntax(Expr(..),Func(..),FuncDec(..),Global(..),Handler(..),State(..),Statement(..), - Ctx(..),Var(..),LSLType(..),Component(..),ctxItems,validLSLScript,CompiledLSLScript(..)) + Ctx(..),Var(..),LSLType(..),Component(..),ctxItems,CompiledLSLScript(..)) --- | Generate a string representing an LSL script from a timestamp (string) --- and a compiled (i.e. validated, with referenced modules included) LSL script. -renderCompiledScript :: String -> CompiledLSLScript -> String +-- | Generate a string representing an LSL script from a timestamp (string) +-- and a compiled (i.e. validated, with referenced modules included) LSL script. +renderCompiledScript :: String -> CompiledLSLScript -> String renderCompiledScript stamp (CompiledLSLScript globals funcs states) = (renderString "// LSL script generated: " . renderString stamp . renderString "\n" . renderGlobals globals . renderFuncs funcs . renderStates states) "" @@ -160,7 +160,8 @@ renderExpression (Cast t expr) = renderString "((" . renderType t . renderChar ')' . renderCtxExpr expr . renderChar ')' renderExpression (Get var) = renderVarAccess var --renderExpression (Const var) = renderVarAccess var -renderExpression (Set var expr) = renderVarAccess var . renderString " = " . renderCtxExpr expr +--renderExpression (Set var expr) = renderChar '(' . renderVarAccess var . renderString " = " . renderCtxExpr expr . renderChar ')' +renderExpression (Set va expr) = renderAssignment va "=" expr renderExpression (IncBy va expr) = renderAssignment va "+=" expr renderExpression (DecBy va expr) = renderAssignment va "-=" expr renderExpression (MulBy va expr) = renderAssignment va "*=" expr @@ -175,7 +176,8 @@ renderBinExpr op expr1 expr2 = renderChar '(' . renderCtxExpr expr1 . renderChar ' ' . renderString op . renderChar ' ' . renderCtxExpr expr2 . renderChar ')' -renderAssignment va op expr = renderVarAccess va . renderChar ' ' . renderString op . renderChar ' ' . renderCtxExpr expr +renderAssignment va op expr = + renderChar '(' . renderVarAccess va . renderChar ' ' . renderString op . renderChar ' ' . renderCtxExpr expr . renderChar ')' renderComponent All = blank renderComponent X = renderString ".x" renderComponent Y = renderString ".y" @@ -195,4 +197,4 @@ renderType LLVoid = blank blank :: String -> String -blank = id +blank = id diff --git a/src/Language/Lsl/Sim.hs b/src/Language/Lsl/Sim.hs --- a/src/Language/Lsl/Sim.hs +++ b/src/Language/Lsl/Sim.hs @@ -177,8 +177,12 @@ llRequestAgentData info@(ScriptInfo _ _ sn pk _) [KVal ak, IVal d] = do key <- lift newKey - av <- (lift getWorldAvatars >>= mlookup ak) <||> (throwError ("no such avatar" ++ ak)) - dataVal <- case d of + av <- (lift getWorldAvatars >>= return . M.lookup ak) -- <||> (throwError ("no such avatar" ++ ak)) + dataVal <- case av of + Nothing -> do + lift $ logFromScript info ("llRequestAgentData: no such avatar - " ++ ak) + return "0" + Just av -> case d of d | d == cDataBorn -> return "1981-01-01" | d == cDataOnline -> return "1" | d == cDataRating -> return "0,0,0,0,0" @@ -1828,13 +1832,17 @@ llGetKey (ScriptInfo _ _ _ pk _) [] = continueWith $ KVal pk llGetOwnerKey info@(ScriptInfo _ _ _ pk _) [KVal k] = - do regionIndex <- getPrimRegion pk + (do regionIndex <- getPrimRegion pk mRegionIndex <- fromErrorT Nothing (getPrimRegion k >>= return . Just) key <- case mRegionIndex of Nothing -> (lift $ logFromScript info "llGetOwnerKey: object key not found") >> return k Just regionIndex' | regionIndex /= regionIndex' -> (lift $ logFromScript info "llGetOwnerKey: object in different simulator") >> return k | otherwise -> getPrimOwner k - continueWith (KVal key) + continueWith (KVal key)) <||> + (do avatars <- lift $ getWorldAvatars + case M.lookup k avatars of + Nothing -> throwError "no such key" + Just _ -> continueWith (KVal k)) llGetLinkNumber (ScriptInfo oid pid _ pk _) [] = if pid /= 0 then continueWith (IVal $ pid + 1) else @@ -3029,6 +3037,7 @@ --processAvatarOutputEvent _ _ = error "not yet implemented(1)" avChat range msg key chan = runAndLogIfErr "problem processing chat" () $ do + lift $ logAMessage LogInfo ("av:" ++ key) ("chat! chan: " ++ show chan ++ ", range: " ++ show range ++ ", message: " ++ show msg) av <- getWorldAvatar key lift $ putWorldEvent 0 $ Chat chan (avatarName av) key msg (avatarRegion av,avatarPosition av) (Just range) diff --git a/src/Language/Lsl/Syntax.hs b/src/Language/Lsl/Syntax.hs --- a/src/Language/Lsl/Syntax.hs +++ b/src/Language/Lsl/Syntax.hs @@ -1,966 +1,1874 @@ -{-# OPTIONS_GHC -XDeriveDataTypeable -XTypeSynonymInstances -XFlexibleContexts #-} --- | Defines the abstract syntax tree for LSL (and LSL Plus extensions). -module Language.Lsl.Syntax ( - -- Types - Expr(..), - Var(..), - FuncDec (..), - Func(..), - LModule(..), - Component(..), - Statement(..), - LSLType(..), - Handler(..), - State(..), - GlobDef(..), - LSLScript(..), - Validity, - Global(..), - SourceContext(..), - Ctx(..), - CompiledLSLScript(..), - Library, - AugmentedLibrary, - CodeErr, - CtxVar, - CtxName, - CtxExpr, - CtxStmt, - ModuleInfo, - -- Values - fromMCtx, - ctxItems, - nullCtx, - ctxVr2Vr, - findFunc, - validLSLScript, - validLibrary, - findState, - predefFuncs, - findFuncDec, - goodHandlers, - libFromAugLib, - isTextLocation) where - -import Language.Lsl.Internal.Type(Component(..),LSLType(..),lslTypeString) -import Language.Lsl.Internal.Constants(isConstant,findConstType) -import Language.Lsl.Internal.EventSigs(simpleLslEventDescriptors) -import Language.Lsl.Internal.FuncSigs(funcSigs) -import Data.Data(Data,Typeable) -import Data.List(find,sort,sortBy,nub) -import Language.Lsl.Internal.Util(ctx,findM,lookupM,filtMap,throwStrError) -import Control.Monad(when,foldM,MonadPlus(..)) -import Control.Monad.Error(MonadError(..),Error(..)) ---trace1 s v = trace (s ++ show v) v - -type CtxVar = Ctx Var - --- | An LSL variable (a name, and a type). -data Var = Var { varName :: String, varType :: LSLType } deriving (Show,Typeable,Data) - -type CtxName = Ctx String - --- | An LSL function declaration (the function name and type information, without associated --- statements. -data FuncDec = FuncDec { funcName :: CtxName, funcType :: LSLType, funcParms :: [CtxVar] } - deriving (Show,Typeable,Data) - -type CtxStmt = Ctx Statement --- | An LSL function definition (return type, parameters and statements. -data Func = Func FuncDec [CtxStmt] deriving (Show,Typeable,Data) - --- | An LSL Plus module, which is a separately 'compiled' unit that can contain --- both global variables and functions, but not states or handlers. -data LModule = LModule [GlobDef] [CtxVar] - deriving (Show,Typeable,Data) - -type CtxExpr = Ctx Expr --- | An LSL expression. -data Expr = IntLit Int - | FloatLit Float - | StringLit String - | ListExpr [CtxExpr] - | VecExpr CtxExpr CtxExpr CtxExpr - | RotExpr CtxExpr CtxExpr CtxExpr CtxExpr - | KeyLit String - | Call CtxName [CtxExpr] - | Add CtxExpr CtxExpr - | Sub CtxExpr CtxExpr - | Mul CtxExpr CtxExpr - | Div CtxExpr CtxExpr - | Mod CtxExpr CtxExpr - | Get (CtxName,Component) - | Set (CtxName,Component) CtxExpr - | BAnd CtxExpr CtxExpr - | BOr CtxExpr CtxExpr - | Xor CtxExpr CtxExpr - | ShiftL CtxExpr CtxExpr - | ShiftR CtxExpr CtxExpr - | And CtxExpr CtxExpr - | Or CtxExpr CtxExpr - | Equal CtxExpr CtxExpr - | NotEqual CtxExpr CtxExpr - | Lt CtxExpr CtxExpr - | Le CtxExpr CtxExpr - | Gt CtxExpr CtxExpr - | Ge CtxExpr CtxExpr - | IncBy (CtxName,Component) CtxExpr - | DecBy (CtxName,Component) CtxExpr - | MulBy (CtxName,Component) CtxExpr - | DivBy (CtxName,Component) CtxExpr - | ModBy (CtxName,Component) CtxExpr - | PostInc (CtxName,Component) - | PostDec (CtxName,Component) - | PreInc (CtxName,Component) - | PreDec (CtxName,Component) - | Not CtxExpr - | Neg CtxExpr - | Inv CtxExpr - | Cast LSLType CtxExpr - | AQString String - | AQInteger String - | AQKey String - | AQFloat String - deriving (Show,Typeable,Data) - --- | An LSL statement. -data Statement = Compound [CtxStmt] - | While CtxExpr Statement - | DoWhile Statement CtxExpr - | For ([CtxExpr]) (Maybe CtxExpr) ([CtxExpr]) Statement - | If CtxExpr Statement Statement - | Decl Var (Maybe CtxExpr) - | NullStmt - | Return (Maybe CtxExpr) - | StateChange String - | Do CtxExpr - | Label String - | Jump String - deriving (Show,Typeable,Data) - -isLabel (Label _) = True -isLabel _ = False - --- | An LSL global variable (this is actually not a source level/syntactic entity -- the set of globals --- for a script is derived after analyzing all included modules. -data Global = GDecl Var (Maybe Expr) - deriving (Show,Typeable,Data) - --- | A global definition (a function, a variable, or a module import statement). -data GlobDef = GV CtxVar (Maybe CtxExpr) | GF Func | GI CtxName [(String,String)] String - deriving (Show,Typeable,Data) --- | An LSL event handler definition. -data Handler = Handler CtxName [CtxVar] [CtxStmt] - deriving (Show,Typeable,Data) - --- | The set of valid handlers supported by LSL. -goodHandlers :: [(String,[LSLType])] -goodHandlers = simpleLslEventDescriptors - --- | An LSL state definition. -data State = State CtxName [Handler] - deriving (Show,Typeable,Data) - --- | An LSL script. -data LSLScript = LSLScript [GlobDef] [State] deriving (Show,Typeable,Data) - -type ModuleInfo = ([Global],[Func]) --- | A collection of modules. -type Library = [(String,Validity LModule)] --- | A collection of mouldes, augmented with additional derived information. -type AugmentedLibrary = [(String,Validity (LModule,ModuleInfo))] - -lslFunc (name,t,ts) = - FuncDec (nullCtx name) t (zipWith (\ x y -> nullCtx $ Var [y] x) ts ['a'..]) -predefFuncs = map lslFunc funcSigs - -findVar name = find (\(Var n _ ) -> n == name) -findType name = - let f Nothing = Nothing - f (Just (Var _ t )) = Just t in f . (findVar name) -findFuncDec name = ctx ("finding function " ++ name) . findM (\ fd -> ctxItem (funcName fd) == name) -findState name = ctx ("finding state " ++ name) . findM (\ (State n _) -> ctxItem n == name) -findFunc name = ctx ("finding function " ++ name) . findM (\ (Func fd _) -> ctxItem (funcName fd) == name) - -lookupModule name lib = - case lookup name lib of - Nothing -> throwStrError "unknown module" - Just (Left (_,s)) -> throwStrError ("invalid library (" ++ s ++ ")") - Just (Right m) -> return m - --- A description of an error and where to find it in the source. -type CodeErr = (SourceContext,String) - --- | An error monad for representing validation errors with respect to LSL code. -type Validity a = Either CodeErr a - -instance Error CodeErr where - noMsg = (UnknownSourceContext,"") - strMsg s = (UnknownSourceContext,s) - -incontext (ctx,s) (Left (ctx',s')) = - case ctx' of - UnknownSourceContext -> Left (ctx,msg) - _ -> Left (ctx',msg) - where msg = if null s then s' else s ++ ": " ++ s' -incontext _ v = v - -incontext' (ctx,s) (Left (_,s')) = Left (ctx,s ++ ": " ++ s') -incontext' _ v = v - --------------------- -matchTypes LLFloat LLInteger = True -matchTypes dest src = dest == src || (all (`elem` [LLKey,LLString]) [dest,src]) - -typeGlob library prefix (vars,funcs) (GV (Ctx ctx (Var name t)) _) = return ((Var (prefix ++ name) t):vars,funcs) -typeGlob library prefix (vars,funcs) (GF (Func (FuncDec name t params) _)) = - return (vars,(FuncDec (fmap (prefix++) name) t params):funcs) -typeGlob library prefix v@(vars,funcs) (GI moduleName _ prefix') = - do (LModule globs _) <- lookupModule (ctxItem moduleName) library - foldM (typeGlob library (prefix++prefix')) (vars,funcs) globs -typeGlobs library gs = foldM (typeGlob library "") ([],[]) gs - -noDupVars :: [String] -> [CtxVar] -> Validity [String] -noDupVars used [] = return used -noDupVars used ((Ctx ctx (Var n t)):vs) = do - when (n `elem` used) $ throwError (ctx, n ++ " already defined") - noDupVars (n:used) vs - -checkName :: Maybe SourceContext -> String -> [String] -> Validity () -checkName (Just ctx) name names = - when (name `elem` names) $ throwError (ctx, name ++ " is multiply defined") - -noDupGlobs :: Maybe SourceContext -> String -> [String] -> Library -> [GlobDef] -> Validity [String] -noDupGlobs forceCtx prefix usedNames library [] = return usedNames -noDupGlobs forceCtx prefix usedNames library ((GV (Ctx ctx (Var name t)) _):gs) = do - checkName (forceCtx `mplus` Just ctx) globName usedNames - noDupGlobs forceCtx prefix (globName:usedNames) library gs - where globName = prefix ++ name -noDupGlobs forceCtx prefix usedNames library ((GF (Func (FuncDec (Ctx ctx name) t params) _)):gs) = do - checkName (forceCtx `mplus` Just ctx) globName usedNames - noDupGlobs forceCtx prefix (globName:usedNames) library gs - where globName = prefix ++ name -noDupGlobs forceCtx prefix usedNames library ((GI (Ctx ctx moduleName) _ prefix'):gs) = do - (LModule globs _) <- incontext (ctx,"") $ lookupModule moduleName library - usedNames' <- noDupGlobs (forceCtx `mplus` Just ctx) (prefix ++ prefix') usedNames library globs - noDupGlobs forceCtx prefix usedNames' library gs - -data CompiledLSLScript = CompiledLSLScript { - scriptGlobals :: ![Global], - scriptFuncs :: ![Func], - scriptStates :: ![State]} - deriving (Show) - -validLSLScript :: Library -> LSLScript -> Validity CompiledLSLScript -validLSLScript library (LSLScript globs states) = - do --noDupGlobs Nothing "" [] library globs - (typedVars,typedFuncs) <- typeGlobs library globs - let vars = reverse typedVars - let funcDecs = typedFuncs ++ predefFuncs - (globvars,funcs,_,_) <- foldM (validGlob library vars funcDecs) ([],[],[],[]) globs - validStates snames [] vars funcDecs states - return (CompiledLSLScript (reverse globvars) funcs states) - where snames = let sname (State cn _) = ctxItem cn in map sname states -validGlob _ vars funcDecs (globvars,funcs,imports,namesUsed) (GV v mexpr) = - do when (isConstant $ varName v') $ throwError (srcCtx v, varName v' ++ " is a predefined constant") - -- find the vars that are defined prior to this global variable -- only one of these - -- vars may be used to initialize the global variable. - when (varName v' `elem` namesUsed) $ throwError (srcCtx v, varName v' ++ " is already defined") - let (vars',_) = break (\ var -> varName var == varName v') vars - case mexpr of - Nothing -> return (GDecl v' Nothing:globvars,funcs,imports, (varName v'):namesUsed) - Just expr -> do - t <- validCtxSimple vars' expr - let vt = varType v' - when (not (matchTypes vt t)) $ throwError (srcCtx expr, "expression not of the correct type") - return ((GDecl v' $ Just (ctxItem expr)):globvars,funcs,imports, (varName v'):namesUsed) - where v' = ctxItem v -validGlob _ vars funcDecs (globvars,funcs,imports,namesUsed) (GF f@(Func (FuncDec name t params) statements)) = - do noDupVars [] params - when (ctxItem name `elem` namesUsed) $ throwError (srcCtx name, ctxItem name ++ " is already defined") - returns <- validStatements False [] funcDecs vars t [] [[],params'] statements - when (not returns && t /= LLVoid) $ - throwError (srcCtx name, "function " ++ (ctxItem name) ++ ": not all code paths return a value") - return (globvars,f:funcs,imports,(ctxItem name):namesUsed) - where params' = ctxItems params -validGlob library vars funcDecs vstate@(globvars,funcs,imports,namesUsed) (GI (Ctx ctx name) bindings prefix) = - let context = incontext' (ctx,"module " ++ name) in - do let imp = (name,sort bindings,prefix) - if imp `elem` imports - then return (globvars,funcs,imports,namesUsed) - else context $ do - (LModule globs freevars) <- context $ lookupModule name library - context $ validBindings vars freevars bindings - (vars',funcDecs') <- context $ typeGlobs library globs - let renames = bindings ++ (map (\ x -> (x,prefix ++ x)) ((map varName vars') ++ (funcNames funcDecs'))) - (gvs,fs,imports',namesUsed') <- foldM (rewriteGlob prefix library renames ((map ctxItem freevars) ++ vars')) vstate globs - return (gvs,fs,imp:imports',namesUsed') - -rewriteGlob _ _ renames vars (globvars,funcs,imports,namesUsed) (GF (Func (FuncDec name t params) statements)) = - do name' <- incontext (srcCtx name, "renaming function " ++ ctxItem name ++ ", " ++ show renames) $ lookupM (ctxItem name) renames - when (name' `elem` namesUsed) $ throwStrError (name' ++ " imported from module is already defined") - let rewrittenFunc = (Func (FuncDec (Ctx (srcCtx name) name') t params) $ rewriteStatements 0 renames statements) - return (globvars,rewrittenFunc:funcs,imports,name':namesUsed) -rewriteGlob _ _ renames vars (globvars,funcs,imports,namesUsed) (GV (Ctx ctx (Var name t)) mexpr) = - do name' <- incontext (ctx,"renaming variable " ++ name) $ lookupM name renames - when (name' `elem` namesUsed) $ throwStrError (name' ++ " imported from module is already defined") - let rewrittenGlobVar = GDecl (Var name' t) $ - case mexpr of - Nothing -> Nothing - Just expr -> Just $ (ctxItem (rewriteCtxExpr renames expr)) - return (rewrittenGlobVar:globvars,funcs,imports,name':namesUsed) -rewriteGlob prefix0 library renames vars vstate@(globvars,funcs,imports,namesUsed) (GI (Ctx ctx mName) bindings prefix) = - do (LModule globs freevars) <- incontext (ctx, "rewriting module " ++ mName) $ lookupModule mName library - incontext (ctx,"") $ validBindings vars freevars bindings - bindings' <- mapM rewriteBinding bindings - let imp = (mName,sort bindings',prefix0 ++ prefix) - if (imp `elem` imports) - then return (globvars,funcs,imports,namesUsed) - else do - (vars',funcDecs') <- typeGlobs library globs - let renames = bindings' ++ map (\ x -> (x,prefix0 ++ prefix ++ x)) (map varName vars' ++ map (ctxItem . funcName) funcDecs') - (gvs,fs,imports',namesUsed') <- foldM (rewriteGlob (prefix0 ++ prefix) library renames vars') vstate globs - return (gvs,fs,imp:imports',namesUsed') - where rewriteBinding (fv,rn) = lookupM rn renames >>= return . ((,) fv) - -validBindings vars freevars bindings = - if length freevars /= length bindings then - throwStrError ("wrong number of bindings in import: " ++ (show $ length freevars) ++ " required") - else let f [] = return () - f ((x,y):xys) = - case (findType x (ctxItems freevars), findType y vars) of - (Nothing,_) -> throwStrError ("free variable " ++ x ++ " not found") - (_,Nothing) -> throwStrError ("global variable " ++ y ++ " not found") - (Just t0,Just t1) | not (matchTypes t0 t1) -> throwStrError ("types of " ++ x ++ " and " ++ y ++ " don't match") - | otherwise -> f xys - in f bindings - -validState snames used vars funcs (State (Ctx ctx name) handlers) = - do when (name `elem` used) $ throwError (ctx, name ++ " already used") - incontext (ctx,"") $ validHandlers snames [] funcs vars handlers - return name - -validStates snames used vars funcs [] = return () -validStates snames used vars funcs (s:ss) = - do name <- validState snames used vars funcs s - validStates snames (name:used) vars funcs ss - -validCast t0 t1 = - let validCasts = [(LLInteger,LLFloat), (LLFloat,LLInteger), - (LLInteger,LLString),(LLString,LLInteger), - (LLFloat,LLString),(LLString,LLFloat), - (LLString,LLVector),(LLVector,LLString), - (LLString,LLKey),(LLKey,LLString), - (LLRot,LLString),(LLString,LLRot), - (LLList,LLString),(LLString,LLList)] in - do when (t0 /= t1 && (t0,t1) `notElem` validCasts) $ throwStrError ("can't cast from " ++ (lslTypeString t0) ++ " to " ++ (lslTypeString t1)) - -validCtxSimple :: [Var] -> Ctx Expr -> Validity LSLType -validCtxSimple vars (Ctx ctx expr) = incontext (ctx,"") $ validSimple vars expr - -validSimple :: [Var] -> Expr -> Validity LSLType -validSimple vars (IntLit i) = return LLInteger -validSimple vars (FloatLit f) = return LLFloat -validSimple vars (StringLit s) = return LLString -validSimple vars (KeyLit k) = return LLKey -validSimple vars (Get (Ctx ctx name,All)) = - (do (Var _ t) <- incontext (ctx, "variable " ++ name) $ findM (\ v -> varName v == name) vars - return t) - `mplus` (findConstType name) -validSimple vars (Get (Ctx ctx name,_)) = throwError (ctx,"can't access vector/rotation component in global variable initialization") -validSimple vars (ListExpr []) = return LLList -validSimple vars (ListExpr (e:es)) = - do t <- validCtxSimple vars e - when (t == LLList) $ throwError (srcCtx e,"lists cannot contain other lists") - validSimple vars (ListExpr es) -validSimple vars (VecExpr e1 e2 e3) = validSimpleStructure vars LLVector [e1,e2,e3] -validSimple vars (RotExpr e1 e2 e3 e4) = validSimpleStructure vars LLRot [e1,e2,e3,e4] -validSimple vars (Neg e) = - do t <- validCtxSimple vars e - when (t `notElem` [LLFloat, LLInteger]) $ throwError (srcCtx e,"operator only applicable to integers and floats in this context") - return t -validSimple vars e = throwStrError ("expression is not valid in a static context.") - -validSimpleStructure vars t [] = return t -validSimpleStructure vars t (e:es) = - do t' <- validCtxSimple vars e - when (t' `notElem` [LLFloat,LLInteger]) $ throwError (srcCtx e, "literal of type " ++ - (lslTypeString t') ++ " not a valid element of " ++ (lslTypeString t)) - validSimpleStructure vars t es - -validExpression :: Expr -> [FuncDec] -> [Var] -> [[Var]] -> Validity LSLType -validExpression (Cast t expr) funcs vars locals = - do t' <- validCtxExpr expr funcs vars locals - incontext (srcCtx expr, "") $ validCast t' t - return t -validExpression (Get ((Ctx ctx name),component)) funcs vars locals = - case (findType name (concat locals ++ vars) `mplus` findConstType name,component) of - (Nothing,_) -> throwError (ctx, "undefined variable or constant: " ++ name) - (Just LLRot,All) -> return LLRot - (Just LLRot,_) -> return LLFloat - (Just LLVector,All) -> return LLVector - (Just LLVector,S) -> throwError (ctx,"s is not a valid component of a vector") - (Just LLVector,_) -> return LLFloat - (Just t,All) -> return t - (Just t,_) -> throwError (ctx,"only vectors and rotations have components") -validExpression (Call name exprs) funcs vars locals = validCall funcs vars locals name exprs -validExpression (Not expr) funcs vars locals = - do t <- validCtxExpr expr funcs vars locals - when (t /= LLInteger) $ throwError (srcCtx expr, "expression is not an integer expression, which is required for applying the Not operator") - return t -validExpression (Neg expr) funcs vars locals = - do t <- validCtxExpr expr funcs vars locals - when (t == LLList) $ throwError (srcCtx expr, "operator not applicable to list type") - return t -validExpression (Inv expr) funcs vars locals = - do t <- validCtxExpr expr funcs vars locals - when (t /= LLInteger) $ throwError (srcCtx expr, "expression is not an integer expression, which is required for applying the inverse operator") - return t -validExpression plus@(Add expr1 expr2) funcs vars locals = - do (t1,t2) <- validEach (expr1,expr2) funcs vars locals - case (t1,t2) of - (LLInteger,LLInteger) -> return LLInteger - (LLInteger,LLFloat) -> return LLFloat - (LLFloat,LLInteger) -> return LLFloat - (LLFloat,LLFloat) -> return LLFloat - (LLVector,LLVector) -> return LLVector - (LLRot,LLRot) -> return LLRot - (LLString,LLString) -> return LLString - (LLList,LLList) -> return LLList - (t,LLList) -> return LLList - (LLList,t) -> return LLList - (t0,t1) -> incompatibleOperands plus t0 t1 -validExpression minus@(Sub expr1 expr2) funcs vars locals = - do (t1,t2) <- validEach (expr1,expr2) funcs vars locals - case (t1,t2) of - (LLInteger,LLInteger) -> return LLInteger - (LLInteger,LLFloat) -> return LLFloat - (LLFloat,LLInteger) -> return LLFloat - (LLFloat,LLFloat) -> return LLFloat - (LLVector,LLVector) -> return LLVector - (LLRot,LLRot) -> return LLRot - (t0,t1) -> incompatibleOperands minus t0 t1 -validExpression expr@(Mul expr1 expr2) funcs vars locals= - do (t1,t2) <- validEach (expr1,expr2) funcs vars locals - case (t1,t2) of - (LLInteger,LLInteger) -> return LLInteger - (LLInteger,LLFloat) -> return LLFloat - (LLFloat,LLInteger) -> return LLFloat - (LLFloat,LLFloat) -> return LLFloat - (LLVector,LLInteger) -> return LLVector - (LLVector,LLFloat) -> return LLVector - (LLFloat,LLVector) -> return LLVector - (LLInteger,LLVector) -> return LLVector - (LLVector,LLVector) -> return LLFloat - (LLVector,LLRot) -> return LLVector - (LLRot,LLRot) -> return LLRot - (t0,t1) -> incompatibleOperands expr t0 t1 -validExpression expr@(Div expr1 expr2) funcs vars locals = - do (t1,t2) <- validEach (expr1,expr2) funcs vars locals - case (t1,t2) of - (LLInteger,LLInteger) -> return LLInteger - (LLInteger,LLFloat) -> return LLFloat - (LLFloat,LLInteger) -> return LLFloat - (LLFloat,LLFloat) -> return LLFloat - (LLVector,LLInteger) -> return LLVector - (LLVector,LLFloat) -> return LLVector - (LLVector,LLRot) -> return LLVector - (LLRot,LLRot) -> return LLRot - (t0,t1) -> incompatibleOperands expr t0 t1 -validExpression expr@(Mod expr1 expr2) funcs vars locals = - do (t1,t2) <- validEach (expr1,expr2) funcs vars locals - case (t1,t2) of - (LLInteger,LLInteger) -> return LLInteger - (LLVector,LLVector) -> return LLVector - _ -> incompatibleOperands expr t1 t2 -validExpression e@(Equal expr1 expr2) funcs vars locals = - do (t1,t2) <- validEach (expr1,expr2) funcs vars locals - case (t1,t2) of - (LLInteger,LLFloat) -> return LLInteger - (LLFloat,LLInteger) -> return LLInteger - (LLString,LLKey) -> return LLInteger - (LLKey,LLString) -> return LLInteger - (t1,t2) | (t1 == t2) -> return LLInteger - | otherwise -> incompatibleOperands e t1 t2 -validExpression e@(NotEqual expr1 expr2) funcs vars locals = - do (t1,t2) <- validEach (expr1,expr2) funcs vars locals - case (t1,t2) of - (LLInteger,LLFloat) -> return LLInteger - (LLFloat,LLInteger) -> return LLInteger - (LLString,LLKey) -> return LLInteger - (LLKey,LLString) -> return LLInteger - (t1,t2) | (t1 == t2) -> return LLInteger - | otherwise -> incompatibleOperands e t1 t2 -validExpression e@(BAnd expr1 expr2) funcs vars locals = validBothInteger (expr1,expr2) funcs vars locals -validExpression e@(BOr expr1 expr2) funcs vars locals = validBothInteger (expr1,expr2) funcs vars locals -validExpression e@(Xor expr1 expr2) funcs vars locals = validBothInteger (expr1,expr2) funcs vars locals -validExpression e@(ShiftL expr1 expr2) funcs vars locals = validBothInteger (expr1,expr2) funcs vars locals -validExpression e@(ShiftR expr1 expr2) funcs vars locals = validBothInteger (expr1,expr2) funcs vars locals -validExpression e@(Gt expr1 expr2) funcs vars locals = validRelExpr (expr1,expr2) funcs vars locals -validExpression e@(Ge expr1 expr2) funcs vars locals = validRelExpr (expr1,expr2) funcs vars locals -validExpression e@(Le expr1 expr2) funcs vars locals = validRelExpr (expr1,expr2) funcs vars locals -validExpression e@(Lt expr1 expr2) funcs vars locals = validRelExpr (expr1, expr2) funcs vars locals -validExpression e@(And expr1 expr2) funcs vars locals = validBothInteger (expr1, expr2) funcs vars locals -validExpression e@(Or expr1 expr2) funcs vars locals = validBothInteger (expr1, expr2) funcs vars locals -validExpression e@(IncBy (name,All) expr) funcs vars locals = - do failIfNoModify name - (t1,t2) <- validNameExpr (name,expr) funcs vars locals - case (t1,t2) of - (LLInteger,LLInteger) -> return LLInteger - (LLFloat,LLInteger) -> return LLFloat - (LLFloat,LLFloat) -> return LLFloat - (LLVector,LLVector) -> return LLVector - (LLRot,LLRot) -> return LLRot - (LLString,LLString) -> return LLString - (LLList,LLList) -> return LLList - (LLList,t) -> return LLList - (t0,t1) -> incompatibleOperands e t0 t1 -validExpression e@(IncBy (name,_) expr) funcs vars locals = - do failIfNoModify name - (t1,t2) <- validNameExpr (name,expr) funcs vars locals - case (t1,t2) of - (t1,t2) | t1 `elem` [LLVector,LLRot] && t2 `elem` [LLFloat,LLInteger] -> return LLFloat - | otherwise -> incompatibleOperands e t1 t2 -validExpression e@(DecBy (name,All) expr) funcs vars locals = - do failIfNoModify name - (t1,t2) <- validNameExpr (name,expr) funcs vars locals - case (t1,t2) of - (LLInteger,LLInteger) -> return LLInteger - (LLFloat,LLInteger) -> return LLFloat - (LLFloat,LLFloat) -> return LLFloat - (LLVector,LLVector) -> return LLVector - (LLRot,LLRot) -> return LLRot - (t0,t1) -> incompatibleOperands e t0 t1 -validExpression e@(DecBy (name,_) expr) funcs vars locals = - do failIfNoModify name - (t1,t2) <- validNameExpr (name,expr) funcs vars locals - case (t1,t2) of - (t1,t2) | t1 `elem` [LLVector,LLRot] && t2 `elem` [LLFloat,LLInteger] -> return LLFloat - | otherwise -> incompatibleOperands e t1 t2 -validExpression e@(MulBy (name,All) expr) funcs vars locals = - do failIfNoModify name - (t1,t2) <- validNameExpr (name,expr) funcs vars locals - case (t1,t2) of - (LLInteger,LLInteger) -> return LLInteger - (LLFloat,LLInteger) -> return LLFloat - (LLFloat,LLFloat) -> return LLFloat - (LLVector,LLInteger) -> return LLVector - (LLVector,LLFloat) -> return LLVector - (LLVector,LLVector) -> return LLVector -- note: LSL compiles this, but it results in runtime error! - (LLVector,LLRot) -> return LLVector - (LLRot,LLRot) -> return LLRot - (t0,t1) -> incompatibleOperands e t0 t1 -validExpression e@(MulBy (name,_) expr) funcs vars locals = - do failIfNoModify name - (t1,t2) <- validNameExpr (name,expr) funcs vars locals - case (t1,t2) of - (t1,t2) | t1 `elem` [LLVector,LLRot] && t2 `elem` [LLFloat,LLInteger] -> return LLFloat - | otherwise -> incompatibleOperands e t1 t2 -validExpression e@(DivBy (name,All) expr) funcs vars locals = - do failIfNoModify name - (t1,t2) <- validNameExpr (name,expr) funcs vars locals - case (t1,t2) of - (LLInteger,LLInteger) -> return LLInteger - (LLFloat,LLInteger) -> return LLFloat - (LLFloat,LLFloat) -> return LLFloat - (LLVector,LLInteger) -> return LLVector - (LLVector,LLFloat) -> return LLVector - (LLVector,LLRot) -> return LLVector - (LLRot,LLRot) -> return LLRot - (t0,t1) -> incompatibleOperands e t0 t1 -validExpression e@(DivBy (name,_) expr) funcs vars locals = - do failIfNoModify name - (t1,t2) <- validNameExpr (name,expr) funcs vars locals - case (t1,t2) of - (t1,t2) | t1 `elem` [LLVector,LLRot] && t2 `elem` [LLFloat,LLInteger] -> return LLFloat - | otherwise -> incompatibleOperands e t1 t2 -validExpression e@(ModBy (name,All) expr) funcs vars locals = - do failIfNoModify name - (t1,t2) <- validNameExpr (name,expr) funcs vars locals - case (t1,t2) of - (LLInteger,LLInteger) -> return LLInteger - (LLVector,LLVector) -> return LLVector - (t0,t1) -> incompatibleOperands e t0 t1 -validExpression e@(ModBy (name,_) expr) funcs vars locals = - do failIfNoModify name - (t1,t2) <- validNameExpr (name,expr) funcs vars locals - case (t1,t2) of - (t1,t2) -> incompatibleOperands e t1 t2 -validExpression e@(PostInc var) funcs vars locals = validIncDecOp var vars locals "++" -validExpression e@(PostDec var) funcs vars locals = validIncDecOp var vars locals "--" -validExpression e@(PreInc var) funcs vars locals = validIncDecOp var vars locals "++" -validExpression e@(PreDec var) funcs vars locals = validIncDecOp var vars locals "++" -validExpression expr0@(Set (name,All) expr) funcs vars locals = - do failIfNoModify name - (t1,t2) <- validNameExpr (name,expr) funcs vars locals - case (t1,t2) of - (LLFloat,LLInteger) -> return LLFloat - (LLKey,LLString) -> return LLKey - (LLString,LLKey) -> return LLString - (t1,t2) | t1 == t2 -> return t1 - | otherwise -> incompatibleOperands expr0 t1 t2 -validExpression expr0@(Set (name,S) expr) funcs vars locals = - do failIfNoModify name - (t1,t2) <- validNameExpr (name,expr) funcs vars locals - case (t1,t2) of - (LLRot,LLFloat) -> return LLFloat - (LLRot,LLInteger) -> return LLFloat - (t0,t1) -> incompatibleOperands expr0 t0 t1 -validExpression expr0@(Set (name,_) expr) funcs vars locals = - do failIfNoModify name - (t1,t2) <- validNameExpr (name,expr) funcs vars locals - case (t1,t2) of - (LLVector,LLFloat) -> return LLFloat - (LLVector,LLInteger) -> return LLFloat - (LLRot,LLFloat) -> return LLFloat - (LLRot,LLInteger) -> return LLFloat - (t0,t1) -> incompatibleOperands expr0 t0 t1 -validExpression (IntLit i) _ _ _ = return LLInteger -validExpression (FloatLit _) _ _ _ = return LLFloat -validExpression (StringLit _) _ _ _ = return LLString -validExpression (KeyLit _) _ _ _ = return LLKey -validExpression (ListExpr es) fs vs ls = do - mapM (\ e -> validListExprElement e fs vs ls) es - return LLList -validExpression (VecExpr xExpr yExpr zExpr) funcs vars locals = - do xt <- validCtxExpr xExpr funcs vars locals - yt <- validCtxExpr yExpr funcs vars locals - zt <- validCtxExpr zExpr funcs vars locals - when (not (all (`elem` [LLInteger,LLFloat]) [xt,yt,zt])) $ throwStrError "invalid components for vector" - return LLVector -validExpression (RotExpr xExpr yExpr zExpr sExpr) funcs vars locals = - do xt <- validCtxExpr xExpr funcs vars locals - yt <- validCtxExpr yExpr funcs vars locals - zt <- validCtxExpr zExpr funcs vars locals - st <- validCtxExpr sExpr funcs vars locals - when (not (all (`elem` [LLInteger,LLFloat]) [xt,yt,zt,st])) $ throwStrError "invalid components for rotation" - return LLRot ---validExpression x funcs vars locals = error ("what to do with " ++ (show x)) - -validListExprElement (Ctx ctx e) funcs vars locals = do - t <- validExpression e funcs vars locals - when (t `elem` [LLVoid,LLList]) $ throwError (ctx,"invalid type for list element") - return () - -validMExpression Nothing funcs vars locals = return LLVoid -validMExpression (Just expr) funcs vars locals = validCtxExpr expr funcs vars locals - -validExpressions es funcs vars locals = mapM_ (\ e -> validCtxExpr e funcs vars locals) es - -validRelExpr (expr1,expr2) funcs vars locals = - do (t1,t2) <- validEach (expr1,expr2) funcs vars locals - case (t1,t2) of - (LLInteger,LLInteger) -> return LLInteger - (LLInteger,LLFloat) -> return LLInteger - (LLFloat, LLInteger) -> return LLInteger - (LLFloat, LLFloat) -> return LLInteger - (t0,t1) -> throwStrError ("operands are of incompatible types") -validBothInteger (expr1, expr2) funcs vars locals = - do (t1,t2) <- validEach (expr1,expr2) funcs vars locals - when (t1 /= LLInteger || t2 /= LLInteger) $ throwStrError ("operands are of incompatible types") - return LLInteger -validEach (expr1, expr2) funcs vars locals = - do t1 <- validCtxExpr expr1 funcs vars locals - t2 <- validCtxExpr expr2 funcs vars locals - return (t1,t2) - -validNameExpr (Ctx ctx name, expr) funcs vars locals = - case (findType name (concat locals ++ vars), - validCtxExpr expr funcs vars locals) of - (Just t1, Right t2) -> return (t1,t2) - (Nothing, _) -> throwError (ctx, "variable " ++ name ++ " not defined") - (_,Left s) -> throwError s -validCall funcs vars locals (Ctx ctx fname) exprs = - do (FuncDec _ t params) <- findFuncDec fname funcs - let vArg _ [] [] = return () - vArg _ (p:ps) [] = throwError (ctx, "mismatch of arguments vs. formal paramters in call to function " ++ fname) - vArg _ [] (a:as) = throwError (ctx, "mismatch of arguments vs. formal paramters in call to function " ++ fname) - vArg n (Var name t:ts) (arg:args) = - do t' <- validCtxExpr arg funcs vars locals - when (not (matchTypes t t')) $ throwError (ctx, "argument " ++ (show n) ++ " in call to function (" ++ fname ++ ") is of wrong type:" ++ (lslTypeString t') ++ ", should be " ++ (lslTypeString t)) - vArg (n+1) ts args - vArg 1 (ctxItems params) exprs - return t - -validCtxExpr (Ctx ctx e) fs vs ls = incontext (ctx,"") $ validExpression e fs vs ls - -validIncDecOp (n@(Ctx ctx name),c) vars locals op = - do failIfNoModify n - case (findType name (concat locals ++ vars),c) of - (Nothing,_) -> throwError (ctx, "variable " ++ name ++ " not found") - (Just LLInteger,All) -> return LLInteger - (Just LLFloat,All) -> return LLFloat - (Just LLRot,S) -> return LLFloat - (Just LLVector,S) -> throwError (ctx, "s is not a valid component of " ++ name) - (Just t,All) -> throwError (ctx, name ++ " is not a valid operand for " ++ op) - (Just LLVector,_) -> return LLFloat - (Just LLRot,_) -> return LLFloat - _ -> throwError (ctx, name ++ " is not a valid operand for " ++ op) - -failIfNoModify (Ctx ctx name) = - when (isConstant name) $ throwError (ctx,"cannot modify " ++ name ++ " because it is a constant") - -incompatibleOperands expr t0 t1 = - throwStrError ("types of the operands aren't compatible (" ++ - (lslTypeString t0) ++ " vs. " ++ (lslTypeString t1) ++ ")") - -defined :: String -> [Var] -> Bool -defined n = any (\ (Var n' _) -> n == n') - -validStatement _ _ funcs vars rtype labels locals@(scope:scopes) returns (Decl var@(Var name t) expr) = - do when (defined name $ concat locals) $ throwStrError ("variable " ++ name ++ " already defined") -- can't hide another local, even in a surrounding scope - when (isConstant name) $ throwStrError ("variable " ++ name ++ " is a predefined constant") - case expr of - Nothing -> return ((var:scope):scopes,returns) - Just expr' -> do t' <- validCtxExpr expr' funcs vars locals - when (not $ matchTypes t t') $ throwError (srcCtx expr', "type of expression in declaration of " ++ name ++ " does not match " ++ lslTypeString t) - return ((var:scope):scopes,returns) -validStatement scallow snames funcs vars rtype labels locals returns (While expr statement) = - do t <- validCtxExpr expr funcs vars locals - --when (t /= LLInteger) $ throwError (srcCtx expr, "expression is not a valid loop condition") - validStatement scallow snames funcs vars rtype labels locals False statement - return (locals,returns) -validStatement scallow snames funcs vars rtype labels locals returns (DoWhile statement expr) = - do t <- validCtxExpr expr funcs vars locals - --when (t /= LLInteger) $ throwError (srcCtx expr, "expression is not a valid loop condition") - validStatement scallow snames funcs vars rtype labels locals False statement - return (locals,returns) -validStatement scallow snames funcs vars rtype labels locals returns (For mexpr1 mexpr2 mexpr3 statement) = - do validExpressions mexpr1 funcs vars locals - validExpressions mexpr3 funcs vars locals - t <- validMExpression mexpr2 funcs vars locals - --when (t /= LLInteger) $ throwStrError ("expression is not a valid loop condition") - validStatement scallow snames funcs vars rtype labels locals False statement - return (locals,returns) -validStatement scallow snames funcs vars rtype labels locals returns (If expr thenStmt elseStmt) = - do t <- validCtxExpr expr funcs vars locals - --when (t /= LLInteger) $ throwError (srcCtx expr, "expression is not a valid 'if' condition") - (_,ret1) <- validStatement scallow snames funcs vars rtype labels locals False thenStmt - (_,ret2) <- validStatement scallow snames funcs vars rtype labels locals False elseStmt - return (locals,returns || ret1 && ret2) -validStatement _ _ _ _ _ _ locals returns NullStmt = return (locals,returns) -validStatement _ _ funcs vars rtype labels locals _ (Return Nothing) = - do when (rtype /= LLVoid) (throwStrError "function must return a value") - return (locals,True) -validStatement _ _ funcs vars rtype labels locals _ (Return (Just expr)) = - do t <- validCtxExpr expr funcs vars locals - when (t /= rtype && not (all (`elem` [LLString,LLKey]) [t,rtype])) (throwStrError "inappropriate return type for function/handler") - return (locals,True) -validStatement scallow snames funcs vars rtype labels locals returns (StateChange name) = do - when (not scallow) $ throwStrError "state changes not allowed from this context" - when (not (name `elem` snames)) $ throwStrError (name ++ " is not a valid state") - return (locals,returns) -validStatement _ _ funcs vars rtype labels locals returns (Do expr) = validCtxExpr expr funcs vars locals>>return (locals,returns) -validStatement scallow snames funcs vars rtype labels locals returns (Compound stmts) = - do returns' <- validStatements scallow snames funcs vars rtype labels ([]:locals) stmts - return (locals,returns || returns') -validStatement _ _ funcs vars rtype labels locals _ (Label _) = return (locals,False) -validStatement _ _ funcs vars rtype labels locals returns (Jump s) = - do when (s `notElem` concat labels) $ throwStrError ("no such label to jump to: " ++ s) - return (locals,returns) - -validStatement' scallow snames funcs vars rtype labels locals returns line (Ctx ctx stmt) = - incontext (ctx, "") $ validStatement scallow snames funcs vars rtype labels locals returns stmt - -validStatements :: Bool -> [String] -> [FuncDec] -> [Var] -> LSLType -> [[String]] -> [[Var]] -> [CtxStmt] -> Validity Bool -validStatements scallow snames funcs vars rtype labels locals stmts = - do let newLabels = map (\ (Label s) -> s) $ filter isLabel (ctxItems stmts) - (_,r') <- foldM (\ (l,r) (n, s) -> - validStatement' scallow snames funcs vars rtype (newLabels:labels) l r n s) (locals,False) $ zip ([1..]::[Int]) stmts - return r' - -validHandler snames used funcs vars (Handler (Ctx ctx name) args stmts) = - do when (name `elem` used) $ throwError (ctx,name ++ " already used in state") - types <- incontext (ctx,"handler: ") $ lookupM name goodHandlers - when (types /= map varType args') $ throwError (ctx,"invalid argument types for handler " ++ name) - when (length args /= (length $ nub $ map varName args')) $ throwError (ctx,"not all argument names are unique for handler " ++ name) - validStatements True snames funcs vars LLVoid [] [[],args'] stmts - return name - where args' = ctxItems args - -validHandlers _ _ _ _ [] = return () -validHandlers snames used funcs vars (h:hs) = - do name <- validHandler snames used funcs vars h - validHandlers snames (name:used) funcs vars hs - --- Validating a library of modules - --- -validModule library m@(LModule globs freevars) = - do --used <- noDupGlobs Nothing "" [] library globs - (typedVars, typedFuncs) <- typeGlobs library globs - let used = (map varName typedVars) ++ (map (ctxItem . funcName) typedFuncs) - noDupVars used freevars - let vars = freevars' ++ reverse typedVars - let funcDecs = typedFuncs ++ predefFuncs - (vs,fs,_,_) <- foldM (validGlob library vars funcDecs) ([],[],[],[]) globs - return (vs,fs) - where freevars' = ctxItems freevars - --- this function isn't partiuclarly efficient! -moduleDependencies lib chain m = - let f (GI s _ _) = Just (ctxItem s) - f _ = Nothing - in do (LModule globs _) <- lookupM m lib - case filtMap f globs of - [] -> return [] - list -> if any (`elem` list) (m:chain) then throwStrError "circular dependency" - else - do deps <- fmap concat ( - let chain' = (m:chain) in - mapM (moduleDependencies lib chain') list) - return $ nub (list ++ deps) - --- sort modules by dependency: for each module in the list, after sorting that module --- will depend only on modules preceding it in the list. This of course implies that --- there can be no circular dependencies in the modules. -sortModules :: [(String,(LModule,[String]))] -> [(String,LModule)] -sortModules modules = - let cmp (name,(_,deplist)) (name',(_,deplist')) = compare (length deplist, name) (length deplist', name') - sort1 [] = [] - sort1 list = - let sorted = sortBy cmp list - (nodeps,deps) = span ((==0).length.snd.snd) sorted - exclude = map fst nodeps - newlist = if length nodeps == 0 then error "circular depencencies in library" - else map (\ (nm,(m,l)) -> (nm, (m,filter (`notElem` exclude) l))) deps - in nodeps ++ sort1 newlist - in map (\ (s,(m,_)) -> (s,m)) $ sort1 modules - -validLibrary modules = - let checkDep (n,m) = case moduleDependencies modules [] n of - Right deps -> (n,Right (m,deps)) - Left s -> (n,Left s) - categorize (good,bad) (n,Left s) = (good,(n,s):bad) - categorize (good,bad) (n,Right (m,deps)) = ((n,(m,deps)):good,bad) - (good,bad) = foldl categorize ([],[]) $ map checkDep modules - sorted = sortModules good - validate augLib (name,m) = - case validModule (libFromAugLib augLib) m of - Left s -> (name, Left s):augLib - Right gs -> (name,Right (m,gs)):augLib - in (foldl validate [] sorted) ++ (map (\ (n,s) -> (n,Left s)) bad) - -libFromAugLib :: AugmentedLibrary -> Library -libFromAugLib augLib = - let f (name,Left s) = (name,Left s) - f (name,Right (lm,_)) = (name, Right lm) - in map f augLib - -tstLib = [ - ("alpha", LModule [GI (nullCtx "beta") [] []] []), - ("beta", LModule [GI (nullCtx "gamma") [] []] []), - ("gamma", LModule [GI (nullCtx "alpha") [] []] []), - ("omega", LModule [GI (nullCtx "lambda") [] []] []), - ("lambda", LModule [GI (nullCtx "kappa") [] [], GI (nullCtx "sigma") [] []] []), - ("kappa", LModule [] []), - ("sigma", LModule [] [])] - -rewriteName renames (Ctx ctx name) = - case lookup name renames of - Nothing -> Ctx ctx name - Just name' -> Ctx ctx name' -rewriteStatements _ _ [] = [] -rewriteStatements n bindings (Ctx c s:ss) = - let (n',bindings',s') = rewriteStatement n bindings s in - (Ctx c s'):(rewriteStatements n' bindings' ss) - -rewriteStatement n bindings (Compound stmts) = (n, bindings, Compound $ rewriteStatements n bindings stmts) -rewriteStatement n bindings (While expr stmt) = - let (_,_,stmt') = rewriteStatement n bindings stmt in - (n, bindings, While (rewriteCtxExpr bindings expr) stmt') -rewriteStatement n bindings (DoWhile stmt expr) = - let (_,_,stmt') = rewriteStatement n bindings stmt in - (n, bindings, DoWhile stmt' (rewriteCtxExpr bindings expr)) -rewriteStatement n bindings (For mexpr1 mexpr2 mexpr3 stmt) = - let (_,_,stmt') = rewriteStatement n bindings stmt - rewriteMExpr = rewriteMExpression bindings - rewriteEs = rewriteCtxExprs bindings in - (n, bindings, For (rewriteEs mexpr1) (rewriteMExpr mexpr2) (rewriteEs mexpr3) stmt') -rewriteStatement n bindings (If expr stmt1 stmt2) = - let (_,_,stmt1') = rewriteStatement n bindings stmt1 - (_,_,stmt2') = rewriteStatement n bindings stmt2 in - (n, bindings, If (rewriteCtxExpr bindings expr) stmt1' stmt2') -rewriteStatement n bindings (Decl (Var name t) val) = - let (n',bindings', newname) = - if any (\(name',_) -> name == name') bindings then let newname = "local" ++ (show n) in (n + 1, (name,newname):bindings, newname) - else (n,bindings,name) - in (n',bindings',Decl (Var newname t) (rewriteMExpression bindings val)) -rewriteStatement n bindings (Return Nothing) = (n, bindings, Return Nothing) -rewriteStatement n bindings (Return (Just expr)) = (n, bindings, Return $ Just $ rewriteCtxExpr bindings expr) -rewriteStatement n bindings (Do expr) = (n, bindings, Do $ rewriteCtxExpr bindings expr) -rewriteStatement n bindings s = (n, bindings, s) - ---rewriteExpressions bindings es = map (rewriteExpression bindings) es - -rewriteCtxExpr bindings (Ctx ctx expr) = Ctx ctx $ rewriteExpression bindings expr -rewriteCtxExprs bindings ctxExprs = map (rewriteCtxExpr bindings) ctxExprs - -rewriteExpression _ (IntLit i) = IntLit i -rewriteExpression _ (FloatLit f) = FloatLit f -rewriteExpression _ (StringLit s) = StringLit s -rewriteExpression _ (KeyLit k) = KeyLit k -rewriteExpression bindings (ListExpr l) = ListExpr $ rewriteCtxExprs bindings l -rewriteExpression bindings (VecExpr e1 e2 e3) = VecExpr (rewriteCtxExpr bindings e1) (rewriteCtxExpr bindings e2) (rewriteCtxExpr bindings e3) -rewriteExpression bindings (RotExpr e1 e2 e3 e4) = RotExpr (rewriteCtxExpr bindings e1) (rewriteCtxExpr bindings e2) (rewriteCtxExpr bindings e3) (rewriteCtxExpr bindings e4) -rewriteExpression bindings (Add expr1 expr2) = Add (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) -rewriteExpression bindings (Sub expr1 expr2) = Sub (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) -rewriteExpression bindings (Mul expr1 expr2) = Mul (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) -rewriteExpression bindings (Div expr1 expr2) = Div (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) -rewriteExpression bindings (Mod expr1 expr2) = Mod (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) -rewriteExpression bindings (BAnd expr1 expr2) = BAnd (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) -rewriteExpression bindings (Xor expr1 expr2) = Xor (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) -rewriteExpression bindings (BOr expr1 expr2) = BOr (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) -rewriteExpression bindings (Lt expr1 expr2) = Lt (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) -rewriteExpression bindings (Gt expr1 expr2) = Gt (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) -rewriteExpression bindings (Le expr1 expr2) = Le (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) -rewriteExpression bindings (Ge expr1 expr2) = Ge (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) -rewriteExpression bindings (And expr1 expr2) = And (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) -rewriteExpression bindings (Or expr1 expr2) = Or (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) -rewriteExpression bindings (ShiftL expr1 expr2) = ShiftL (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) -rewriteExpression bindings (ShiftR expr1 expr2) = ShiftR (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) -rewriteExpression bindings (Equal expr1 expr2) = Equal (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) -rewriteExpression bindings (NotEqual expr1 expr2) = NotEqual (rewriteCtxExpr bindings expr1) (rewriteCtxExpr bindings expr2) -rewriteExpression bindings (Inv expr) = Inv $ rewriteCtxExpr bindings expr -rewriteExpression bindings (Not expr) = Not $ rewriteCtxExpr bindings expr -rewriteExpression bindings (Neg expr) = Neg $ rewriteCtxExpr bindings expr -rewriteExpression bindings (Call name exprs) = Call (rewriteName bindings name) $ rewriteCtxExprs bindings exprs -rewriteExpression bindings (Cast t expr) = Cast t $ rewriteCtxExpr bindings expr -rewriteExpression bindings (Get (name,component)) = Get (rewriteName bindings name,component) ---rewriteExpression bindings c@(Const _) = c -rewriteExpression bindings (Set (name,component) expr) = Set (rewriteName bindings name,component) (rewriteCtxExpr bindings expr) -rewriteExpression bindings (IncBy (name,component) expr) = IncBy (rewriteName bindings name,component) (rewriteCtxExpr bindings expr) -rewriteExpression bindings (DecBy (name,component) expr) = DecBy (rewriteName bindings name,component) (rewriteCtxExpr bindings expr) -rewriteExpression bindings (MulBy (name,component) expr) = MulBy (rewriteName bindings name,component) (rewriteCtxExpr bindings expr) -rewriteExpression bindings (DivBy (name,component) expr) = DivBy (rewriteName bindings name,component) (rewriteCtxExpr bindings expr) -rewriteExpression bindings (ModBy (name,component) expr) = ModBy (rewriteName bindings name,component) (rewriteCtxExpr bindings expr) -rewriteExpression bindings e@(PostInc _) = e -rewriteExpression bindings e@(PostDec _) = e -rewriteExpression bindings e@(PreInc _) = e -rewriteExpression bindings e@(PreDec _) = e -rewriteMExpression bindings = fmap (rewriteCtxExpr bindings) - -data SourceContext = TextLocation { textLine0 :: Int, textColumn0 :: Int, textLine1 :: Int, textColumn1 :: Int, textName :: String } | - UnknownSourceContext - deriving (Show,Typeable,Data) - -isTextLocation (TextLocation _ _ _ _ _) = True -isTextLocation _ = False - --- | A wrapper that can associate a source code context with a value (e.g. a syntax value). -data Ctx a = Ctx { srcCtx :: SourceContext, ctxItem :: a } deriving (Show,Typeable,Data) -instance Functor Ctx where - fmap f (Ctx c v) = (Ctx c $ f v) - -ctxItems = map ctxItem - -fromMCtx :: Maybe (Ctx a) -> Maybe a -fromMCtx = fmap ctxItem - -nullCtx :: a -> Ctx a -nullCtx = Ctx UnknownSourceContext - -funcNames = map (ctxItem.funcName) - -ctxVr2Vr :: (Ctx a,b) -> (a,b) -ctxVr2Vr (Ctx _ name,c) = (name,c) +{-# OPTIONS_GHC -XDeriveDataTypeable -XTypeSynonymInstances -XFlexibleContexts -XGeneralizedNewtypeDeriving + -XTemplateHaskell -XNoMonomorphismRestriction -XFlexibleInstances #-} +-- | Defines the abstract syntax tree for LSL (and LSL Plus extensions). +module Language.Lsl.Syntax ( + -- Types + Expr(..), + Var(..), + FuncDec (..), + Func(..), + LModule(..), + Component(..), + Statement(..), + LSLType(..), + Handler(..), + State(..), + GlobDef(..), + LSLScript(..), + Validity, + Global(..), + SourceContext(..), + Ctx(..), + CompiledLSLScript(..), + Library, + AugmentedLibrary, + CodeErr, + CtxVar, + CtxName, + CtxExpr, + CtxStmt, + ModuleInfo, + Codebase(..), + -- Values + fromMCtx, + ctxItems, + nullCtx, + ctxVr2Vr, + findFunc, + --validLSLScript, + --validLibrary, + moduleFromScript, + findState, + predefFuncs, + findFuncDec, + goodHandlers, + libFromAugLib, + isTextLocation, + compileLSLScript, + compileLSLScript', + compileLibrary, + VState, + emptyValidationState) where + +import Language.Lsl.Internal.Type(Component(..),LSLType(..),lslTypeString) +import Language.Lsl.Internal.Constants(isConstant,findConstType) +import Language.Lsl.Internal.EventSigs(simpleLslEventDescriptors) +import Language.Lsl.Internal.FuncSigs(funcSigs) +import Language.Lsl.Internal.AccessGenerator(genAccessorsForType,genMAccessorsForType) +import Data.Generics +import Data.Data(Data,Typeable) +import Data.List(find,sort,sortBy,nub,foldl') +import qualified Data.Map as M +import Data.Maybe(isJust,isNothing) +import Language.Lsl.Internal.Util(ctx,findM,lookupM,filtMap,throwStrError) +import Control.Monad(when,foldM,MonadPlus(..)) +import Control.Monad.Error(MonadError(..),Error(..)) +import qualified Control.Monad.State as S(State) +import Control.Monad.State hiding(State) + +import Debug.Trace +--trace1 s v = trace (s ++ show v) v + +data SourceContext = TextLocation { textLine0 :: Int, textColumn0 :: Int, textLine1 :: Int, textColumn1 :: Int, textName :: String } | + UnknownSourceContext + deriving (Show,Typeable,Data) + +isTextLocation (TextLocation _ _ _ _ _) = True +isTextLocation _ = False + +-- | A wrapper that can associate a source code context with a value (e.g. a syntax value). +data Ctx a = Ctx { srcCtx :: SourceContext, ctxItem :: a } deriving (Show,Typeable,Data) +instance Functor Ctx where + fmap f (Ctx c v) = (Ctx c $ f v) + +ctxItems = map ctxItem + +fromMCtx :: Maybe (Ctx a) -> Maybe a +fromMCtx = fmap ctxItem + +nullCtx :: a -> Ctx a +nullCtx = Ctx UnknownSourceContext + +funcNames = map (ctxItem.funcName) + +ctxVr2Vr :: (Ctx a,b) -> (a,b) +ctxVr2Vr (Ctx _ name,c) = (name,c) + +type CtxVar = Ctx Var + +-- | An LSL variable (a name, and a type). +data Var = Var { varName :: String, varType :: LSLType } deriving (Show,Typeable,Data) + +type CtxName = Ctx String + +-- | An LSL function declaration (the function name and type information, without associated +-- statements. +data FuncDec = FuncDec { funcName :: CtxName, funcType :: LSLType, funcParms :: [CtxVar] } + deriving (Show,Typeable,Data) + +type CtxStmt = Ctx Statement +-- | An LSL function definition (return type, parameters and statements. +data Func = Func FuncDec [CtxStmt] deriving (Show,Typeable,Data) + +-- | An LSL Plus module, which is a separately 'compiled' unit that can contain +-- both global variables and functions, but not states or handlers. +data LModule = LModule [GlobDef] [CtxVar] + deriving (Show,Typeable,Data) + +type CtxExpr = Ctx Expr +-- | An LSL expression. +data Expr = IntLit Int + | FloatLit Float + | StringLit String + | ListExpr [CtxExpr] + | VecExpr CtxExpr CtxExpr CtxExpr + | RotExpr CtxExpr CtxExpr CtxExpr CtxExpr + | KeyLit String + | Call CtxName [CtxExpr] + | Add CtxExpr CtxExpr + | Sub CtxExpr CtxExpr + | Mul CtxExpr CtxExpr + | Div CtxExpr CtxExpr + | Mod CtxExpr CtxExpr + | Get (CtxName,Component) + | Set (CtxName,Component) CtxExpr + | BAnd CtxExpr CtxExpr + | BOr CtxExpr CtxExpr + | Xor CtxExpr CtxExpr + | ShiftL CtxExpr CtxExpr + | ShiftR CtxExpr CtxExpr + | And CtxExpr CtxExpr + | Or CtxExpr CtxExpr + | Equal CtxExpr CtxExpr + | NotEqual CtxExpr CtxExpr + | Lt CtxExpr CtxExpr + | Le CtxExpr CtxExpr + | Gt CtxExpr CtxExpr + | Ge CtxExpr CtxExpr + | IncBy (CtxName,Component) CtxExpr + | DecBy (CtxName,Component) CtxExpr + | MulBy (CtxName,Component) CtxExpr + | DivBy (CtxName,Component) CtxExpr + | ModBy (CtxName,Component) CtxExpr + | PostInc (CtxName,Component) + | PostDec (CtxName,Component) + | PreInc (CtxName,Component) + | PreDec (CtxName,Component) + | Not CtxExpr + | Neg CtxExpr + | Inv CtxExpr + | Cast LSLType CtxExpr + | AQString String + | AQInteger String + | AQKey String + | AQFloat String + deriving (Show,Typeable,Data) + +-- | An LSL statement. +data Statement = Compound [CtxStmt] + | While CtxExpr Statement + | DoWhile Statement CtxExpr + | For ([CtxExpr]) (Maybe CtxExpr) ([CtxExpr]) Statement + | If CtxExpr Statement Statement + | Decl Var (Maybe CtxExpr) + | NullStmt + | Return (Maybe CtxExpr) + | StateChange String + | Do CtxExpr + | Label String + | Jump String + deriving (Show,Typeable,Data) + +isLabel (Label _) = True +isLabel _ = False + +-- | An LSL global variable (this is actually not a source level/syntactic entity -- the set of globals +-- for a script is derived after analyzing all included modules. +data Global = GDecl Var (Maybe Expr) + deriving (Show,Typeable,Data) + +-- | A global definition (a function, a variable, or a module import statement). +data GlobDef = GV CtxVar (Maybe CtxExpr) | GF Func | GI CtxName [(String,String)] String + deriving (Show,Typeable,Data) +-- | An LSL event handler definition. +data Handler = Handler CtxName [CtxVar] [CtxStmt] + deriving (Show,Typeable,Data) + +-- | The set of valid handlers supported by LSL. +goodHandlers :: [(String,[LSLType])] +goodHandlers = simpleLslEventDescriptors + +-- | An LSL state definition. +data State = State CtxName [Handler] + deriving (Show,Typeable,Data) + +-- | An LSL script. +data LSLScript = LSLScript [GlobDef] [State] deriving (Show,Typeable,Data) + +type ModuleInfo = ([Global],[Func]) +-- | A collection of modules. +type Library = [(String,Validity LModule)] +-- | A collection of mouldes, augmented with additional derived information. +type AugmentedLibrary = [(String,Validity (LModule,ModuleInfo))] + +data Codebase = Codebase { codebaseLib :: AugmentedLibrary, codebaseScripts :: [(String,Validity CompiledLSLScript)] } + +lslFunc (name,t,ts) = + FuncDec (nullCtx name) t (zipWith (\ x y -> nullCtx $ Var [y] x) ts ['a'..]) +predefFuncs = map lslFunc funcSigs + +findVar name = find (\(Var n _ ) -> n == name) +findType name = + let f Nothing = Nothing + f (Just (Var _ t )) = Just t in f . (findVar name) +findFuncDec name = ctx ("finding function " ++ name) . findM (\ fd -> ctxItem (funcName fd) == name) +findState name = ctx ("finding state " ++ name) . findM (\ (State n _) -> ctxItem n == name) +findFunc name = ctx ("finding function " ++ name) . findM (\ (Func fd _) -> ctxItem (funcName fd) == name) + +lookupModule :: String -> Library -> Validity LModule +lookupModule name lib = + case lookup name lib of + Nothing -> throwError [(UnknownSourceContext, "unknown module")] + Just (Left ((_,s):_)) -> throwError [(UnknownSourceContext, "invalid library (" ++ s ++ ")")] + Just (Right m) -> return m + +-- A description of an error and where to find it in the source. +type CodeErr = (SourceContext,String) + +ctxFromCodeErr = fst +msgFromCodeErr = snd + +-- | An error monad for representing validation errors with respect to LSL code. +type Validity a = Either [CodeErr] a + +instance Error [CodeErr] where + noMsg = [(UnknownSourceContext,"")] + strMsg s = [(UnknownSourceContext,s)] + +incontext (ctx,s) (Left ((ctx',s'):_)) = + case ctx' of + UnknownSourceContext -> Left [(ctx,msg)] + _ -> Left [(ctx',msg)] + where msg = if null s then s' else s ++ ": " ++ s' +incontext _ v = v + +incontext' (ctx,s) (Left ((_,s'):_)) = Left [(ctx,s ++ ": " ++ s')] +incontext' _ v = v + +-------------------- +matchTypes LLFloat LLInteger = True +matchTypes dest src = dest == src || (all (`elem` [LLKey,LLString]) [dest,src]) + +typeGlob library prefix (vars,funcs) (GV (Ctx ctx (Var name t)) _) = return ((Var (prefix ++ name) t):vars,funcs) +typeGlob library prefix (vars,funcs) (GF (Func (FuncDec name t params) _)) = + return (vars,(FuncDec (fmap (prefix++) name) t params):funcs) +typeGlob library prefix v@(vars,funcs) (GI moduleName _ prefix') = + do (LModule globs _) <- lookupModule (ctxItem moduleName) library + foldM (typeGlob library (prefix++prefix')) (vars,funcs) globs +typeGlobs library gs = foldM (typeGlob library "") ([],[]) gs + +noDupVars :: [String] -> [CtxVar] -> Validity [String] +noDupVars used [] = return used +noDupVars used ((Ctx ctx (Var n t)):vs) = do + when (n `elem` used) $ throwError [(ctx, n ++ " already defined")] + noDupVars (n:used) vs + +checkName :: Maybe SourceContext -> String -> [String] -> Validity () +checkName (Just ctx) name names = + when (name `elem` names) $ throwError [(ctx, name ++ " is multiply defined")] + +data CompiledLSLScript = CompiledLSLScript { + scriptGlobals :: ![Global], + scriptFuncs :: ![Func], + scriptStates :: ![State]} + deriving (Show) + +data RefPos = RefPos { refPosName :: !String, refPosLine :: !Int, refPosCol :: !Int } + deriving (Show,Eq,Ord) + +data ValidationState = ValidationState { + vsLib :: !Library, + vsGlobalRegistry :: !(M.Map String SourceContext), + vsLocalRegistry :: ![M.Map String SourceContext], + vsLocalVars :: ![[Var]], + vsRefs :: !(M.Map RefPos SourceContext), + vsLabels :: ![[String]], + vsModules :: ![String], + vsGlobDefs :: ![GlobDef], + vsStates :: ![State], + vsGlobals :: ![Global], + vsFuncs :: ![Func], + vsErr :: ![CodeErr], + vsWarn :: ![CodeErr], + vsNamesUsed :: [String], + vsGVs :: ![Var], + vsGFs :: ![FuncDec], + vsStateNames :: ![String], + vsEntryPointInfo :: !(LSLType,Bool), + vsBranchReturns :: !Bool, + vsHandlersUsed :: ![String], + vsImports :: ![(String,[(String,String)],String)], + vsContext :: [SourceContext] + } + +emptyValidationState = ValidationState { + vsLib = [], + vsGlobalRegistry = M.empty, + vsLocalRegistry = [], + vsLocalVars = [], + vsRefs = M.empty, + vsLabels = [], + vsModules = [], + vsGlobDefs = [], + vsStates = [], + vsGlobals = [], + vsFuncs = [], + vsErr = [], + vsWarn = [], + vsNamesUsed = [], + vsGVs = [], + vsGFs = [], + vsStateNames = [], + vsEntryPointInfo = (LLVoid,False), + vsBranchReturns = False, + vsHandlersUsed = [], + vsImports = [], + vsContext = [] + } +-- generate set'xxx methods for all the record selectors in the above type... +-- warning: all types mentioned in the above declaration must be defined (lexically) prior to +-- the following splice +-- double warning: the 'set' functions generated can only be used in code that +-- lexically follows this splice +$(genAccessorsForType ''ValidationState) -- a Template Haskell splice... +-- this splice requires the above splice, and, because the author of the splice was too lazy to +-- generate type signatures, also requires -XNoMonomorphismRestriction +$(genMAccessorsForType ''ValidationState) -- a Template Haskell splice... + +type VState a = S.State ValidationState a + +--vsmRegisterGlobal :: Ctx Var -> VState () +vsmRegisterGlobalName name ctx = get'vsGlobalRegistry >>= put'vsGlobalRegistry . (M.insert name ctx) +vsmRegisterGlobal (Ctx ctx (Var name t)) = vsmRegisterGlobalName name ctx +vsmRegisterFunc (Func (FuncDec (Ctx ctx name) _ _) _) = vsmRegisterGlobalName name ctx + +vsmRegisterLocalName name ctx = do + lregistry <- get'vsLocalRegistry + case lregistry of + [] -> error "no local scope on stack" + (top:rest) -> put'vsLocalRegistry (M.insert name ctx top : rest) + +vsmAddGlobalRef name ctx = do + registry <- get'vsGlobalRegistry + case M.lookup name registry of + Nothing -> return () + Just UnknownSourceContext -> return () + Just ctx -> do + refs <- get'vsRefs + put'vsRefs (M.insert (RefPos name (textLine0 ctx) (textColumn0 ctx)) ctx refs) + +vsmAddRef name ctx = do + lr <- get'vsLocalRegistry + go lr + where go [] = vsmAddGlobalRef name ctx + go (top:rest) = do + case M.lookup name top of + Nothing -> go rest + Just UnknownSourceContext -> return () + Just ctx -> do + refs <- get'vsRefs + put'vsRefs (M.insert (RefPos name (textLine0 ctx) (textColumn0 ctx)) ctx refs) + +vsmAddGV :: Var -> VState () +vsmAddGV var = get'vsGVs >>= put'vsGVs . (var:) +vsmAddGF :: FuncDec -> VState () +vsmAddGF fd = get'vsGFs >>= put'vsGFs . (fd:) + +vsmAddFunc :: Func -> VState () +vsmAddFunc func = get'vsFuncs >>= put'vsFuncs . (func :) + +vsmAddGlobal :: Global -> VState () +vsmAddGlobal global = get'vsGlobals >>= put'vsGlobals . (global :) + +vsmAddState :: State -> VState () +vsmAddState state = get'vsStates >>= put'vsStates . (state :) + +vsmAddLocal :: SourceContext -> Var -> VState () +vsmAddLocal ctx v@(Var name _) = do + locals <- get'vsLocalVars + case locals of + [] -> error "internal error - no local scope" + (top:rest) -> + if (defined name $ concat locals) || (isConstant name) + then vsmAddErr (ctx, name ++ " is already defined") + else do + put'vsLocalVars ((v:top):rest) + vsmRegisterLocalName name ctx + +vsmAddImport imp = get'vsImports >>= put'vsImports . (imp:) + +vsmAddToNamesUsed :: String -> VState () +vsmAddToNamesUsed name = get'vsNamesUsed >>= put'vsNamesUsed . (name :) + +vsmWithNewScope :: VState a -> VState a +vsmWithNewScope action = do + get'vsLocalRegistry >>= put'vsLocalRegistry . (M.empty:) + get'vsLabels >>= put'vsLabels . ([]:) + get'vsLocalVars >>= put'vsLocalVars . ([]:) + val <- action + get'vsLocalRegistry >>= (\ (_:reg) -> put'vsLocalRegistry reg) + get'vsLabels >>= (\ (_:labels) -> put'vsLabels labels) + get'vsLocalVars >>= (\ (_:vars) -> put'vsLocalVars vars) + return val + +vsmWithModule :: String -> VState () -> VState () +vsmWithModule mname action = get'vsModules >>= put'vsModules . (mname:) >> action >> get'vsModules >>= (\ (_:ms) -> put'vsModules ms) + +vsmAddErr :: CodeErr -> VState () +vsmAddErr err = do + ctx <- get'vsContext >>= return . safeHead + errs <- get'vsErr + put'vsErr ((maybe (ctxFromCodeErr err) id ctx, msgFromCodeErr err) : errs) + +vsmAddErrs :: [CodeErr] -> VState () +vsmAddErrs = mapM_ vsmAddErr + +vsmAddLabel :: String -> VState () +vsmAddLabel label = do + labels <- get'vsLabels + case labels of + [] -> error "no local scope!" + (top:rest) -> put'vsLabels ((label:top):rest) + +vsmAddHandler handlerName = get'vsHandlersUsed >>= put'vsHandlersUsed . (handlerName:) + +vsmWithContext :: SourceContext -> VState a -> VState a +vsmWithContext srcCtx action = do + ctxs <- get'vsContext + put'vsContext (srcCtx:ctxs) + v <- action + put'vsContext ctxs + return v + +vsmInEntryPoint :: LSLType -> Bool -> VState a -> VState a +vsmInEntryPoint t stateChangeAllow action = do + put'vsEntryPointInfo (t,stateChangeAllow) + action + +vsmInBranch :: VState a -> VState a +vsmInBranch action = do + info <- get'vsBranchReturns + put'vsBranchReturns False + val <- action + put'vsBranchReturns info + return val + +vsmWithinState action = do + put'vsHandlersUsed [] + action + +whenM mp action = do + p <- mp + when p action + +whenJust mv action = + case mv of + Nothing -> return () + Just v -> action v + +whenIsJust mv p action = + case mv of + Nothing -> return () + Just v | p v -> action + | otherwise -> return () + +safeHead [] = Nothing +safeHead (x:_) = Just x + +vsmFirstErr :: VState (Maybe CodeErr) +vsmFirstErr = get'vsErr >>= \ l -> case l of + l@(_:_) -> return $ Just $ last l -- list is reversed... + _ -> return Nothing + +compileLSLScript' :: Library ->LSLScript -> Validity CompiledLSLScript +compileLSLScript' library script = evalState (compileLSLScript script) (emptyValidationState { vsLib = library }) + +compileLSLScript :: LSLScript -> VState (Validity CompiledLSLScript) +compileLSLScript (LSLScript globs states) = do + preprocessGlobDefs_ "" globs + preprocessStates states + mapM_ vsmAddGF predefFuncs + mapM_ compileGlob globs + mapM_ compileState states + err <- get'vsErr -- vsmFirstErr + case err of + [] -> do + globals <- get'vsGlobals + funcs <- get'vsFuncs + states <- get'vsStates + return $ Right $ CompiledLSLScript (reverse globals) (reverse funcs) (reverse states) + _ -> return $ Left $ reverse err + +preprocessStates states = let snames = map (\ (State cn _) -> ctxItem cn) states in put'vsStateNames snames + +preprocessGlobDefs :: String -> [GlobDef] -> VState ([Var],[FuncDec]) +preprocessGlobDefs prefix globs = do + preprocessGlobDefs_ prefix globs + vars <- get'vsGVs + funcDecs <- get'vsGFs + return (vars,funcDecs) + +preprocessGlobDefs_ :: String -> [GlobDef] -> VState () +preprocessGlobDefs_ = mapM_ . preprocessGlobDef + +preprocessGlobDef :: String -> GlobDef -> VState () +preprocessGlobDef prefix (GV (Ctx ctx v@(Var name t)) _) = vsmAddGV (Var (prefix ++ name) t) +preprocessGlobDef prefix (GF (Func (FuncDec name t params) _)) = vsmAddGF (FuncDec (fmap (prefix++) name) t params) +preprocessGlobDef prefix (GI moduleName _ prefix') = do + lib <- get'vsLib + case lookupModule (ctxItem moduleName) lib of + Left err -> vsmAddErrs err + Right (LModule globs _) -> mapM_ (preprocessGlobDef (prefix++prefix')) globs + +compileGlob :: GlobDef -> VState () +compileGlob (GV v mexpr) = do + let v' = ctxItem v + when (isConstant $ varName v') (vsmAddErr (srcCtx v, varName v' ++ " is a predefined constant")) + namesUsed <- get'vsNamesUsed + gvs <- get'vsGVs + when (varName v' `elem` namesUsed) (vsmAddErr (srcCtx v, varName v' ++ " is already defined")) + whenJust mexpr $ \ expr -> do + let (_,gvs') = break (\ var -> varName var == varName v') gvs + mt <- compileCtxSimple (drop 1 gvs') expr + whenJust mt $ \ t -> when (not (varType v' `matchTypes` t)) (vsmAddErr (srcCtx v, "expression not of the correct type")) + vsmRegisterGlobal v + vsmAddToNamesUsed (varName v') + vsmAddGlobal (GDecl v' (fmap ctxItem mexpr)) +compileGlob (GF f@(Func (FuncDec name t params) statements)) = + vsmWithNewScope $ do + compileParams params + vsmInEntryPoint t False $ do + whenM ((return elem) `ap` (return $ ctxItem name) `ap` get'vsNamesUsed) (vsmAddErr (srcCtx name, ctxItem name ++ " is already defined")) + returns <- compileStatements statements + when (not returns && t /= LLVoid) (vsmAddErr (srcCtx name, ctxItem name ++ ": not all code paths return a value")) + vsmRegisterFunc f + vsmAddToNamesUsed $ ctxItem name + vsmAddFunc f +compileGlob (GI (Ctx ctx name) bindings prefix) = + vsmWithModule name $ do + let imp = (name, sort bindings, prefix) + imports <- get'vsImports + when (not (imp `elem` imports)) $ do + library <- get'vsLib + case lookupModule name library of + Left errs -> vsmAddErrs (map (\ (_,err) -> (ctx, "module " ++ name ++ ": " ++ err)) errs) + Right (LModule globs freevars) -> do + vars <- get'vsGVs + case validBindings vars freevars bindings of + Left err -> vsmAddErr (ctx, err) + Right () -> do + let (vars',funcDecs') = evalState (preprocessGlobDefs "" globs) (emptyValidationState { vsLib = library }) + let renames = bindings ++ (map (\ x -> (x,prefix ++ x)) ((map varName vars') ++ (funcNames funcDecs'))) + vsmAddImport imp + vsmWithContext ctx $ mapM_ (rewriteGlob' prefix renames (map ctxItem freevars ++ vars')) globs + +rewriteGlob' prefix renames vars (GF (Func (FuncDec name t params) statements)) = + case lookup (ctxItem name) renames of + Nothing -> vsmAddErr (srcCtx name, "can't rename " ++ ctxItem name ++ ": not found") + Just name' -> do + namesUsed <- get'vsNamesUsed + if name' `elem` namesUsed + then vsmAddErr (srcCtx name, name' ++ " imported from module is already defined") + else let rewrittenFunc = (Func (FuncDec (Ctx (srcCtx name) name') t params) $ rewriteStatements 0 renames statements) + in do vsmAddToNamesUsed name' + vsmRegisterFunc rewrittenFunc + vsmAddFunc rewrittenFunc +rewriteGlob' prefix renames vars (GV (Ctx ctx (Var name t)) mexpr) = + case lookup name renames of + Nothing -> vsmAddErr (ctx, "can't rename " ++ name ++ ": not found") + Just name' -> do + namesUsed <- get'vsNamesUsed + if name' `elem` namesUsed + then vsmAddErr (ctx, name' ++ " imported from module is already defined") + else let rewrittenGlobVar = GDecl (Var name' t) (fmap (ctxItem . (rewriteCtxExpr renames)) mexpr) + in do vsmAddToNamesUsed name' + vsmRegisterGlobal (Ctx ctx (Var name' t)) + vsmAddGlobal rewrittenGlobVar +rewriteGlob' prefix0 renames vars (GI (Ctx ctx mName) bindings prefix) = + do lib <- get'vsLib + case lookupModule mName lib of + Left errs -> vsmAddErrs (map (\ (_,err) -> (ctx, err)) errs) + Right (LModule globs freevars) -> do + case validBindings vars freevars bindings of + Left err -> vsmAddErr (ctx, err) + Right _ -> do + bindings' <- mapM rewriteBinding bindings + let imp = (mName,sort bindings', prefix0 ++ prefix) + imports <- get'vsImports + when (not (imp `elem` imports)) $ do + let (vars',funcDecs') = evalState (preprocessGlobDefs "" globs) (emptyValidationState { vsLib = lib }) + let renames = bindings' ++ map (\ x -> (x,prefix0 ++ prefix ++ x)) (map varName vars' ++ map (ctxItem . funcName) funcDecs') + vsmAddImport imp + mapM_ (rewriteGlob' (prefix0 ++ prefix) renames vars') globs + where rewriteBinding (fv,rn) = case lookup rn renames of + Nothing -> vsmAddErr (ctx, rn ++ ": not found") >> return (fv,rn) + Just rn' -> return (fv,rn') + +compileState :: State -> VState () +compileState state@(State nm handlers) = + vsmWithinState $ do + states <- get'vsStates + when (isJust (find (\ (State x _)-> ctxItem x == ctxItem nm) states)) $ + vsmAddErr (srcCtx nm, ctxItem nm ++ " already defined") + mapM_ compileHandler handlers + vsmAddState state + +compileHandler (Handler (Ctx ctx name) args stmts) = + vsmWithNewScope $ do + used <- get'vsHandlersUsed + if name `elem` used then vsmAddErr (ctx, name ++ " already used in this state") + else vsmAddHandler name + case lookup name goodHandlers of + Nothing -> vsmAddErr (ctx, name ++ " is not a valid handler name") + Just types -> when (types /= map varType (ctxItems args)) $ vsmAddErr (ctx, "invalid parameter types for handler " ++ name) + compileParams args + vsmInEntryPoint LLVoid True $ compileStatements stmts + +compileCtxSimple :: [Var] -> CtxExpr -> VState (Maybe LSLType) +compileCtxSimple gvs (Ctx ctx expr) = do + t <- compileSimple gvs expr + case t of + Nothing -> vsmAddErr (ctx,"expression is not valid as an initializer for a global variable") >> return t + _ -> return t + +compileSimple :: [Var] -> Expr -> VState (Maybe LSLType) +compileSimple _ (IntLit i) = return $ Just LLInteger +compileSimple _ (FloatLit i) = return $ Just LLFloat +compileSimple _ (StringLit s) = return $ Just LLString +compileSimple _ (KeyLit k) = return $ Just LLKey +compileSimple gvs (Get (Ctx ctx name, All)) = do + vsmAddGlobalRef name ctx + let var = find (\ v -> varName v == name) gvs + case var of + Just (Var _ t) -> return $ Just t + Nothing -> case findConstType name of + Nothing -> vsmAddErr (ctx,"variable " ++ name ++ " not found") >> return Nothing + Just t -> return $ Just t +compileSimple _ (Get (Ctx ctx name,_)) = do + vsmAddGlobalRef name ctx + vsmAddErr (ctx, "can't access vector/rotation component in global variable initialization") >> return Nothing +compileSimple _ (ListExpr []) = return $ Just LLList +compileSimple vars (ListExpr (e:es)) = do + mt <- compileCtxSimple vars e + case mt of + Nothing -> return Nothing + Just t -> do + when (t == LLList) (vsmAddErr (srcCtx e, "lists cannot contain other lists")) + compileSimple vars (ListExpr es) +compileSimple vars (VecExpr e1 e2 e3) = compileSimpleStructure vars LLVector [e1,e2,e3] +compileSimple vars (RotExpr e1 e2 e3 e4) = compileSimpleStructure vars LLRot [e1,e2,e3,e4] +compileSimple vars (Neg e) = do + mt <- compileCtxSimple vars e + case mt of + Nothing -> return Nothing + Just t -> + if (t `notElem` [LLFloat,LLInteger]) + then vsmAddErr (srcCtx e, "operator only applicable to integers and floats in this context") >> return Nothing + else return (Just t) +compileSimple _ e = return Nothing + +compileSimpleStructure :: [Var] -> LSLType -> [CtxExpr] -> VState (Maybe LSLType) +compileSimpleStructure _ t [] = return (Just t) +compileSimpleStructure vars t (e:es) = do + mt <- compileCtxSimple vars e + case mt of + Nothing -> return Nothing + Just t' -> + if (t' `notElem` [LLFloat,LLInteger]) + then vsmAddErr (srcCtx e, "literal of type " ++ lslTypeString t' ++ " is not a valid element of " ++ lslTypeString t) + >> return Nothing + else compileSimpleStructure vars t es + +compileStatement :: Ctx Statement -> VState Bool +compileStatement (Ctx ctx (Decl var@(Var name t) expr)) = do + vsmAddLocal ctx var + case expr of + Nothing -> return () + Just expr' -> do mt' <- compileCtxExpr expr' + case mt' of + Nothing -> return () + Just t' -> when (not $ matchTypes t t') $ vsmAddErr (srcCtx expr', "type of expression in declaration of " ++ name ++ " does not match " ++ lslTypeString t) + get'vsBranchReturns +compileStatement (Ctx ctx (While expr statement)) = do + t <- compileCtxExpr expr + vsmInBranch $ compileStatement (nullCtx statement) + get'vsBranchReturns +compileStatement (Ctx ctx(DoWhile statement expr)) = + do t <- compileCtxExpr expr + vsmInBranch $ compileStatement (nullCtx statement) + get'vsBranchReturns +compileStatement (Ctx ctx (For mexpr1 mexpr2 mexpr3 statement)) = + do compileExpressions mexpr1 + compileExpressions mexpr3 + t <- compileMExpression mexpr2 + vsmInBranch $ compileStatement (nullCtx statement) + get'vsBranchReturns +compileStatement (Ctx ctx (If expr thenStmt elseStmt)) = + do t <- compileCtxExpr expr + ret1 <- vsmInBranch $ compileStatement (nullCtx thenStmt) + ret2 <- vsmInBranch $ compileStatement (nullCtx elseStmt) + returns <- get'vsBranchReturns + put'vsBranchReturns (returns || (ret1 && ret2)) + get'vsBranchReturns +compileStatement (Ctx ctx NullStmt) = get'vsBranchReturns +compileStatement (Ctx ctx (Return Nothing)) = + do (rtype,_) <- get'vsEntryPointInfo + when (rtype /= LLVoid) (vsmAddErr (ctx,"function must return a value")) + put'vsBranchReturns True + return True +compileStatement (Ctx ctx (Return (Just expr))) = + do t <- compileCtxExpr expr + case t of + 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")) + put'vsBranchReturns True + return True +compileStatement (Ctx ctx (StateChange name)) = do + (_,scallow) <- get'vsEntryPointInfo + snames <- get'vsStateNames + when (not scallow) $ vsmAddErr (ctx,"state changes not allowed from this context") + when (not (name `elem` snames)) $ vsmAddErr (ctx,name ++ " is not a valid state") + get'vsBranchReturns +compileStatement (Ctx ctx (Do expr)) = compileCtxExpr expr >> get'vsBranchReturns +compileStatement (Ctx ctx (Compound stmts)) = compileStatements stmts +compileStatement (Ctx ctx (Label _)) = put'vsBranchReturns False >> return False +compileStatement (Ctx ctx (Jump s)) = + do labels <- get'vsLabels + when (s `notElem` concat labels) $ vsmAddErr (ctx, "no such label to jump to: " ++ s) + get'vsBranchReturns + + +compileStatements :: [CtxStmt] -> VState Bool +compileStatements stmts = + do let newLabels = map (\ (Label s) -> s) $ filter isLabel (ctxItems stmts) + vsmWithNewScope $ do + mapM_ vsmAddLabel newLabels + mapM_ compileStatement stmts + get'vsBranchReturns + +compileParams :: [CtxVar] -> VState () +compileParams vs = mapM_ ( \(Ctx ctx v) -> vsmAddLocal ctx v) vs + +isCastValid t t' = (t' == t) || (t,t') `elem` validCasts + where validCasts = [(LLInteger,LLFloat), (LLFloat,LLInteger), + (LLInteger,LLString),(LLString,LLInteger), + (LLFloat,LLString),(LLString,LLFloat), + (LLString,LLVector),(LLVector,LLString), + (LLString,LLKey),(LLKey,LLString), + (LLRot,LLString),(LLString,LLRot), + (LLList,LLString),(LLString,LLList)] + +compileCtxExpr :: Ctx Expr -> VState (Maybe LSLType) +compileCtxExpr (Ctx ctx (Cast t expr)) = + do mt <- compileCtxExpr expr + case mt of + Nothing -> return () + Just t' -> when (not $ isCastValid t' t) $ vsmAddErr (ctx,"cannot cast a value of type " ++ lslTypeString t' ++ " to type " ++ lslTypeString t) + return (Just t) +compileCtxExpr (Ctx ctx0 (Get ((Ctx ctx name),component))) = do + vsmAddRef name ctx + vars <- get'vsGVs + locals <- get'vsLocalVars + let varList = (concat locals ++ vars) + case (findType name varList `mplus` findConstType name,component) of + (Nothing,_) -> vsmAddErr (ctx, "undefined variable or constant: " ++ name) >> return Nothing + (Just LLRot,All) -> return $ Just LLRot + (Just LLRot,_) -> return $ Just LLFloat + (Just LLVector,All) -> return $ Just LLVector + (Just LLVector,S) -> vsmAddErr (ctx0,"s is not a valid component of a vector") >> (return $ Just LLFloat) + (Just LLVector,_) -> return $ Just LLFloat + (Just t,All) -> return $ Just t + (Just t,_) -> vsmAddErr (ctx,"only vectors and rotations have components") >> return Nothing +compileCtxExpr (Ctx ctx (Call name exprs)) = compileCall name exprs +compileCtxExpr (Ctx ctx (Not expr)) = + do mt <- compileCtxExpr expr + (mt `whenIsJust` (/=LLInteger)) $ vsmAddErr (ctx, "operator not applicable to non-integer type") + return $ Just LLInteger +compileCtxExpr (Ctx ctx (Neg expr)) = + do mt <- compileCtxExpr expr + (mt `whenIsJust` (==LLList)) $ vsmAddErr (ctx, "operator not applicable to list type") + return mt +compileCtxExpr (Ctx ctx (Inv expr)) = + do mt <- compileCtxExpr expr + (mt `whenIsJust` (/=LLInteger)) $ vsmAddErr (srcCtx expr, "operator not applicable to non-integer type") + return mt +compileCtxExpr (Ctx ctx plus@(Add expr1 expr2)) = + do (mt1,mt2) <- compileEach (expr1,expr2) + case (mt1,mt2) of + (Nothing,Just t2) -> return (Just t2) + (Just t1,Nothing) -> return (Just t1) + (Nothing,Nothing) -> return Nothing + (Just LLInteger,Just LLInteger) -> return $ Just LLInteger + (Just LLInteger,Just LLFloat) -> return $ Just LLFloat + (Just LLFloat,Just LLInteger) -> return $ Just LLFloat + (Just LLFloat,Just LLFloat) -> return $ Just LLFloat + (Just LLVector,Just LLVector) -> return $ Just LLVector + (Just LLRot,Just LLRot) -> return $ Just LLRot + (Just LLString,Just LLString) -> return $ Just LLString + (Just LLList,Just LLList) -> return $ Just LLList + (Just t,Just LLList) -> return $ Just LLList + (Just LLList,Just t) -> return $ Just LLList + (Just t0,Just t1) -> reportIncompatibleOperands ctx t0 t1 >> return Nothing +compileCtxExpr (Ctx ctx minus@(Sub expr1 expr2)) = + do (mt1,mt2) <- compileEach (expr1,expr2) + case (mt1,mt2) of + (Nothing,Just t2) -> return (Just t2) + (Just t1,Nothing) -> return (Just t1) + (Nothing,Nothing) -> return Nothing + (Just LLInteger,Just LLInteger) -> return $ Just LLInteger + (Just LLInteger,Just LLFloat) -> return $ Just LLFloat + (Just LLFloat,Just LLInteger) -> return $ Just LLFloat + (Just LLFloat,Just LLFloat) -> return $ Just LLFloat + (Just LLVector,Just LLVector) -> return $ Just LLVector + (Just LLRot,Just LLRot) -> return $ Just LLRot + (Just t0,Just t1) -> reportIncompatibleOperands ctx t0 t1 >> return Nothing +compileCtxExpr (Ctx ctx expr@(Mul expr1 expr2)) = + do (mt1,mt2) <- compileEach (expr1,expr2) + case (mt1,mt2) of + (Nothing,Just t2) -> return (Just t2) + (Just t1,Nothing) -> return (Just t1) + (Nothing,Nothing) -> return Nothing + (Just LLInteger,Just LLInteger) -> return $ Just LLInteger + (Just LLInteger,Just LLFloat) -> return $ Just LLFloat + (Just LLFloat,Just LLInteger) -> return $ Just LLFloat + (Just LLFloat,Just LLFloat) -> return $ Just LLFloat + (Just LLVector,Just LLInteger) -> return $ Just LLVector + (Just LLVector,Just LLFloat) -> return $ Just LLVector + (Just LLFloat,Just LLVector) -> return $ Just LLVector + (Just LLInteger,Just LLVector) -> return $ Just LLVector + (Just LLVector,Just LLVector) -> return $ Just LLFloat + (Just LLVector,Just LLRot) -> return $ Just LLVector + (Just LLRot,Just LLRot) -> return $ Just LLRot + (Just t0,Just t1) -> reportIncompatibleOperands ctx t0 t1 >> return Nothing +compileCtxExpr (Ctx ctx expr@(Div expr1 expr2)) = + do (mt1,mt2) <- compileEach (expr1,expr2) + case (mt1,mt2) of + (Nothing,Just t2) -> return (Just t2) + (Just t1,Nothing) -> return (Just t1) + (Nothing,Nothing) -> return Nothing + (Just LLInteger,Just LLInteger) -> return $ Just LLInteger + (Just LLInteger,Just LLFloat) -> return $ Just LLFloat + (Just LLFloat,Just LLInteger) -> return $ Just LLFloat + (Just LLFloat,Just LLFloat) -> return $ Just LLFloat + (Just LLVector,Just LLInteger) -> return $ Just LLVector + (Just LLVector,Just LLFloat) -> return $ Just LLVector + (Just LLVector,Just LLRot) -> return $ Just LLVector + (Just LLRot,Just LLRot) -> return $ Just LLRot + (Just t0,Just t1) -> reportIncompatibleOperands ctx t0 t1 >> return Nothing +compileCtxExpr (Ctx ctx expr@(Mod expr1 expr2)) = + do (mt1,mt2) <- compileEach (expr1,expr2) + case (mt1,mt2) of + (Nothing,Just t2) -> return (Just t2) + (Just t1,Nothing) -> return (Just t1) + (Nothing,Nothing) -> return Nothing + (Just LLInteger,Just LLInteger) -> return $ Just LLInteger + (Just LLVector,Just LLVector) -> return $ Just LLVector + (Just t1,Just t2) -> reportIncompatibleOperands ctx t1 t2 >> return Nothing +compileCtxExpr (Ctx ctx e@(Equal expr1 expr2)) = + do (mt1,mt2) <- compileEach (expr1,expr2) + case (mt1,mt2) of + (Nothing,Just t2) -> return (Just t2) + (Just t1,Nothing) -> return (Just t1) + (Nothing,Nothing) -> return Nothing + (Just LLInteger,Just LLFloat) -> return $ Just LLInteger + (Just LLFloat,Just LLInteger) -> return $ Just LLInteger + (Just LLString,Just LLKey) -> return $ Just LLInteger + (Just LLKey,Just LLString) -> return $ Just LLInteger + (Just t1,Just t2) | (t1 == t2) -> return $ Just LLInteger + | otherwise -> reportIncompatibleOperands ctx t1 t2 >> return Nothing +compileCtxExpr (Ctx ctx e@(NotEqual expr1 expr2)) = + do (mt1,mt2) <- compileEach (expr1,expr2) + case (mt1,mt2) of + (Nothing,Just t2) -> return (Just t2) + (Just t1,Nothing) -> return (Just t1) + (Nothing,Nothing) -> return Nothing + (Just LLInteger,Just LLFloat) -> return $ Just LLInteger + (Just LLFloat,Just LLInteger) -> return $ Just LLInteger + (Just LLString,Just LLKey) -> return $ Just LLInteger + (Just LLKey,Just LLString) -> return $ Just LLInteger + (Just t1,Just t2) | (t1 == t2) -> return $ Just LLInteger + | otherwise -> reportIncompatibleOperands ctx t1 t2 >> return Nothing +compileCtxExpr (Ctx ctx e@(BAnd expr1 expr2)) = compileBothInteger ctx (expr1,expr2) +compileCtxExpr (Ctx ctx e@(BOr expr1 expr2)) = compileBothInteger ctx (expr1,expr2) +compileCtxExpr (Ctx ctx e@(Xor expr1 expr2)) = compileBothInteger ctx (expr1,expr2) +compileCtxExpr (Ctx ctx e@(ShiftL expr1 expr2)) = compileBothInteger ctx (expr1,expr2) +compileCtxExpr (Ctx ctx e@(ShiftR expr1 expr2)) = compileBothInteger ctx (expr1,expr2) +compileCtxExpr (Ctx ctx e@(Gt expr1 expr2)) = compileRelExpr ctx (expr1,expr2) +compileCtxExpr (Ctx ctx e@(Ge expr1 expr2)) = compileRelExpr ctx (expr1,expr2) +compileCtxExpr (Ctx ctx e@(Le expr1 expr2)) = compileRelExpr ctx (expr1,expr2) +compileCtxExpr (Ctx ctx e@(Lt expr1 expr2)) = compileRelExpr ctx (expr1, expr2) +compileCtxExpr (Ctx ctx e@(And expr1 expr2)) = compileBothInteger ctx (expr1, expr2) +compileCtxExpr (Ctx ctx e@(Or expr1 expr2)) = compileBothInteger ctx (expr1, expr2) +compileCtxExpr (Ctx ctx e@(IncBy (name,All) expr)) = + do reportErrorIfNoModify name + (mt1,mt2) <- compileNameExpr (name,expr) + case (mt1,mt2) of + (Nothing,Nothing) -> return Nothing + (Just t1,Nothing) -> return $ Just t1 + (Nothing,Just t2) -> return $ Just t2 + (Just LLInteger,Just LLInteger) -> return $ Just LLInteger + (Just LLFloat,Just LLInteger) -> return $ Just LLFloat + (Just LLFloat,Just LLFloat) -> return $ Just LLFloat + (Just LLVector,Just LLVector) -> return $ Just LLVector + (Just LLRot,Just LLRot) -> return $ Just LLRot + (Just LLString,Just LLString) -> return $ Just LLString + (Just LLList,Just LLList) -> return $ Just LLList + (Just LLList,Just t) -> return $ Just LLList + (Just t1,Just t2) -> reportIncompatibleOperands ctx t1 t2 >> return Nothing +compileCtxExpr (Ctx ctx e@(IncBy (name,_) expr) ) = + do reportErrorIfNoModify name + (mt1,mt2) <- compileNameExpr (name,expr) + case (mt1,mt2) of + (Nothing,Nothing) -> return Nothing + (Just t1,Nothing) -> return $ Just t1 + (Nothing,Just t2) -> return $ Just t2 + (Just t1,Just t2) | t1 `elem` [LLVector,LLRot] && t2 `elem` [LLFloat,LLInteger] -> return $ Just LLFloat + | otherwise -> reportIncompatibleOperands ctx t1 t2 >> return Nothing +compileCtxExpr (Ctx ctx e@(DecBy (name,All) expr)) = + do reportErrorIfNoModify name + (mt1,mt2) <- compileNameExpr (name,expr) + case (mt1,mt2) of + (Nothing,Nothing) -> return Nothing + (Just t1,Nothing) -> return $ Just t1 + (Nothing,Just t2) -> return $ Just t2 + (Just LLInteger,Just LLInteger) -> return $ Just LLInteger + (Just LLFloat,Just LLInteger) -> return $ Just LLFloat + (Just LLFloat,Just LLFloat) -> return $ Just LLFloat + (Just LLVector,Just LLVector) -> return $ Just LLVector + (Just LLRot,Just LLRot) -> return $ Just LLRot + (Just t1,Just t2) -> reportIncompatibleOperands ctx t1 t2 >> return Nothing +compileCtxExpr (Ctx ctx e@(DecBy (name,_) expr)) = + do reportErrorIfNoModify name + (mt1,mt2) <- compileNameExpr (name,expr) + case (mt1,mt2) of + (Nothing,Nothing) -> return Nothing + (Just t1,Nothing) -> return $ Just t1 + (Nothing,Just t2) -> return $ Just t2 + (Just t1,Just t2) | t1 `elem` [LLVector,LLRot] && t2 `elem` [LLFloat,LLInteger] -> return $ Just LLFloat + | otherwise -> reportIncompatibleOperands ctx t1 t2 >> return Nothing +compileCtxExpr (Ctx ctx e@(MulBy (name,All) expr)) = + do reportErrorIfNoModify name + (mt1,mt2) <- compileNameExpr (name,expr) + case (mt1,mt2) of + (Nothing,Nothing) -> return Nothing + (Just t1,Nothing) -> return $ Just t1 + (Nothing,Just t2) -> return $ Just t2 + (Just LLInteger,Just LLInteger) -> return $ Just LLInteger + (Just LLFloat,Just LLInteger) -> return $ Just LLFloat + (Just LLFloat,Just LLFloat) -> return $ Just LLFloat + (Just LLVector,Just LLInteger) -> return $ Just LLVector + (Just LLVector,Just LLFloat) -> return $ Just LLVector + (Just LLVector,Just LLVector) -> return $ Just LLVector -- note: LSL compiles this, but it results in runtime error! + (Just LLVector,Just LLRot) -> return $ Just LLVector + (Just LLRot,Just LLRot) -> return $ Just LLRot + (Just t1,Just t2) -> reportIncompatibleOperands ctx t1 t2 >> return Nothing +compileCtxExpr (Ctx ctx e@(MulBy (name,_) expr)) = + do reportErrorIfNoModify name + (mt1,mt2) <- compileNameExpr (name,expr) + case (mt1,mt2) of + (Nothing,Nothing) -> return Nothing + (Just t1,Nothing) -> return $ Just t1 + (Nothing,Just t2) -> return $ Just t2 + (Just t1,Just t2) | t1 `elem` [LLVector,LLRot] && t2 `elem` [LLFloat,LLInteger] -> return $ Just LLFloat + | otherwise -> reportIncompatibleOperands ctx t1 t2 >> return Nothing +compileCtxExpr (Ctx ctx e@(DivBy (name,All) expr)) = + do reportErrorIfNoModify name + (mt1,mt2) <- compileNameExpr (name,expr) + case (mt1,mt2) of + (Nothing,Nothing) -> return Nothing + (Just t1,Nothing) -> return $ Just t1 + (Nothing,Just t2) -> return $ Just t2 + (Just LLInteger,Just LLInteger) -> return $ Just LLInteger + (Just LLFloat,Just LLInteger) -> return $ Just LLFloat + (Just LLFloat,Just LLFloat) -> return $ Just LLFloat + (Just LLVector,Just LLInteger) -> return $ Just LLVector + (Just LLVector,Just LLFloat) -> return $ Just LLVector + (Just LLVector,Just LLRot) -> return $ Just LLVector + (Just LLRot,Just LLRot) -> return $ Just LLRot + (Just t1,Just t2) -> reportIncompatibleOperands ctx t1 t2 >> return Nothing +compileCtxExpr (Ctx ctx e@(DivBy (name,_) expr)) = + do reportErrorIfNoModify name + (mt1,mt2) <- compileNameExpr (name,expr) + case (mt1,mt2) of + (Nothing,Nothing) -> return Nothing + (Just t1,Nothing) -> return $ Just t1 + (Nothing,Just t2) -> return $ Just t2 + (Just t1,Just t2) | t1 `elem` [LLVector,LLRot] && t2 `elem` [LLFloat,LLInteger] -> return $ Just LLFloat + | otherwise -> reportIncompatibleOperands ctx t1 t2 >> return Nothing +compileCtxExpr (Ctx ctx e@(ModBy (name,All) expr)) = + do reportErrorIfNoModify name + (mt1,mt2) <- compileNameExpr (name,expr) + case (mt1,mt2) of + (Nothing,Nothing) -> return Nothing + (Just t1,Nothing) -> return $ Just t1 + (Nothing,Just t2) -> return $ Just t2 + (Just LLInteger,Just LLInteger) -> return $ Just LLInteger + (Just LLVector,Just LLVector) -> return $ Just LLVector + (Just t1,Just t2) -> reportIncompatibleOperands ctx t1 t2 >> return Nothing +compileCtxExpr (Ctx ctx e@(ModBy (name,_) expr)) = + do reportErrorIfNoModify name + (mt1,mt2) <- compileNameExpr (name,expr) + case (mt1,mt2) of + (Nothing,Nothing) -> return Nothing + (Just t1,Nothing) -> return $ Just t1 + (Nothing,Just t2) -> return $ Just t2 + (Just t1,Just t2) -> reportIncompatibleOperands ctx t1 t2 >> return Nothing +compileCtxExpr (Ctx ctx e@(PostInc var)) = compileIncDecOp var "++" +compileCtxExpr (Ctx ctx e@(PostDec var)) = compileIncDecOp var "--" +compileCtxExpr (Ctx ctx e@(PreInc var)) = compileIncDecOp var "++" +compileCtxExpr (Ctx ctx e@(PreDec var)) = compileIncDecOp var "++" +compileCtxExpr (Ctx ctx expr0@(Set (name,All) expr)) = + do reportErrorIfNoModify name + (mt1,mt2) <- compileNameExpr (name,expr) + case (mt1,mt2) of + (Nothing,Nothing) -> return Nothing + (Just t1,Nothing) -> return $ Just t1 + (Nothing,Just t2) -> return $ Just t2 + (Just LLFloat,Just LLInteger) -> return $ Just LLFloat + (Just LLKey,Just LLString) -> return $ Just LLKey + (Just LLString,Just LLKey) -> return $ Just LLString + (Just t1,Just t2) | t1 == t2 -> return $ Just t1 + | otherwise -> reportIncompatibleOperands ctx t1 t2 >> return Nothing +compileCtxExpr (Ctx ctx expr0@(Set (name,S) expr)) = + do reportErrorIfNoModify name + (mt1,mt2) <- compileNameExpr (name,expr) + case (mt1,mt2) of + (Nothing,Nothing) -> return Nothing + (Just t1,Nothing) -> return $ Just t1 + (Nothing,Just t2) -> return $ Just t2 + (Just LLRot,Just LLFloat) -> return $ Just LLFloat + (Just LLRot,Just LLInteger) -> return $ Just LLFloat + (Just t1,Just t2) -> reportIncompatibleOperands ctx t1 t2 >> return Nothing +compileCtxExpr (Ctx ctx expr0@(Set (name,_) expr)) = + do reportErrorIfNoModify name + (mt1,mt2) <- compileNameExpr (name,expr) + case (mt1,mt2) of + (Nothing,Nothing) -> return Nothing + (Just t1,Nothing) -> return $ Just t1 + (Nothing,Just t2) -> return $ Just t2 + (Just LLVector,Just LLFloat) -> return $ Just LLFloat + (Just LLVector,Just LLInteger) -> return $ Just LLFloat + (Just LLRot,Just LLFloat) -> return $ Just LLFloat + (Just LLRot,Just LLInteger) -> return $ Just LLFloat + (Just t1,Just t2) -> reportIncompatibleOperands ctx t1 t2 >> return Nothing +compileCtxExpr (Ctx ctx (IntLit i)) = return $ Just LLInteger +compileCtxExpr (Ctx ctx (FloatLit _)) = return $ Just LLFloat +compileCtxExpr (Ctx ctx (StringLit _)) = return $ Just LLString +compileCtxExpr (Ctx ctx (KeyLit _)) = return $ Just LLKey +compileCtxExpr (Ctx ctx (ListExpr es)) = do + mapM compileListExprElement es + return $ Just LLList +compileCtxExpr (Ctx ctx (VecExpr xExpr yExpr zExpr)) = + do xt <- compileCtxExpr xExpr + yt <- compileCtxExpr yExpr + zt <- compileCtxExpr zExpr + when (not (all (`elem` [LLInteger,LLFloat]) [c | Just c <- [xt,yt,zt]])) $ vsmAddErr (ctx, "invalid components for vector") + return $ Just LLVector +compileCtxExpr (Ctx ctx (RotExpr xExpr yExpr zExpr sExpr)) = + do xt <- compileCtxExpr xExpr + yt <- compileCtxExpr yExpr + zt <- compileCtxExpr zExpr + st <- compileCtxExpr sExpr + when (not (all (`elem` [LLInteger,LLFloat]) [ c | Just c <- [xt,yt,zt,st]])) $ vsmAddErr (ctx, "invalid components for rotation") + return $ Just LLRot + +reportErrorIfNoModify (Ctx ctx name) = + when (isConstant name) $ vsmAddErr (ctx, "cannot modify " ++ name ++ " because it is a constant") + +reportIncompatibleOperands ctx t0 t1 = + vsmAddErr (ctx,"the types of the operands aren't compatible (" ++ lslTypeString t0 ++ " vs. " ++ lslTypeString t1 ++ ")") + +compileExpressions es = mapM_ compileCtxExpr es +compileMExpression Nothing = return (Just LLVoid) +compileMExpression (Just expr) = compileCtxExpr expr + +compileCall (Ctx ctx fname) exprs = do + vsmAddRef fname ctx + funcs <- get'vsGFs + case findFuncDec fname funcs of + Nothing -> vsmAddErr (ctx,fname ++ ": no such function in scope") >> return Nothing + Just (FuncDec _ t params) -> + let vArg :: Int -> [Var] -> [Ctx Expr] -> VState () + vArg _ [] [] = return () + vArg _ (p:ps) [] = vsmAddErr (ctx, "mismatch of arguments vs. formal paramters in call to function " ++ fname) + vArg _ [] (a:as) = vsmAddErr (ctx, "mismatch of arguments vs. formal paramters in call to function " ++ fname) + vArg n (Var name t:ts) (arg:args) = + do mt' <- compileCtxExpr arg + case mt' of + Nothing -> return () + Just t' -> when (not (matchTypes t t')) $ vsmAddErr (ctx, "argument " ++ (show n) ++ " in call to function (" ++ fname ++ ") is of wrong type:" ++ (lslTypeString t') ++ ", should be " ++ (lslTypeString t)) + vArg (n+1) ts args + in vArg 1 (ctxItems params) exprs >> return (Just t) + +compileEach :: (Ctx Expr,Ctx Expr) -> VState (Maybe LSLType, Maybe LSLType) +compileEach (expr1,expr2) = do + mt1 <- compileCtxExpr expr1 + mt2 <- compileCtxExpr expr2 + return (mt1,mt2) +compileBothInteger ctx (expr1,expr2) = do + (mt1,mt2) <- compileEach (expr1,expr2) + case (mt1,mt2) of + (Just LLInteger,Just LLInteger) -> return $ Just LLInteger + (Just _, Just _) -> vsmAddErr (ctx,"operands are of incompatible type") >> return Nothing + _ -> return Nothing +compileRelExpr ctx (expr1,expr2) = do + do (mt1,mt2) <- compileEach (expr1,expr2) + case (mt1,mt2) of + (Nothing,_) -> return Nothing + (_,Nothing) -> return Nothing + (Just LLInteger,Just LLInteger) -> return $ Just LLInteger + (Just LLInteger,Just LLFloat) -> return $ Just LLInteger + (Just LLFloat,Just LLInteger) -> return $ Just LLInteger + (Just LLFloat,Just LLFloat) -> return $ Just LLInteger + (Just t0,Just t1) -> vsmAddErr (ctx,"operands are of incompatible types") >> return Nothing +compileNameExpr (Ctx ctx name,expr) = do + vsmAddRef name ctx + locals <- get'vsLocalVars + globvars <- get'vsGVs + mt <- compileCtxExpr expr + let mvt = findType name (concat locals ++ globvars) + when (isNothing mvt) $ vsmAddErr (ctx,"variable " ++ name ++ " not defined") + return (mvt,mt) + +compileIncDecOp (n@(Ctx ctx name),c) op = do + vsmAddRef name ctx + reportErrorIfNoModify n + locals <- get'vsLocalVars + vars <- get'vsGVs + case (findType name (concat locals ++ vars),c) of + (Nothing,_) -> vsmAddErr (ctx, "variable " ++ name ++ " not found") >> return Nothing + (Just LLInteger,All) -> return $ Just LLInteger + (Just LLFloat,All) -> return $ Just LLFloat + (Just LLRot,S) -> return $ Just LLFloat + (Just LLVector,S) -> vsmAddErr (ctx, "s is not a valid component of " ++ name) >> return Nothing + (Just t,All) -> vsmAddErr (ctx, name ++ " is not a valid operand for " ++ op) >> return Nothing + (Just LLVector,_) -> return $ Just LLFloat + (Just LLRot,_) -> return $ Just LLFloat + _ -> vsmAddErr (ctx, name ++ " is not a valid operand for " ++ op) >> return Nothing + +compileListExprElement e@(Ctx ctx _) = do + mt <- compileCtxExpr e + case mt of + Nothing -> return () + Just t | t `elem` [LLVoid,LLList] -> vsmAddErr (ctx,"invalid list element") + | otherwise -> return () + +validLSLScript :: Library -> LSLScript -> Validity CompiledLSLScript +validLSLScript library (LSLScript globs states) = + do (typedVars,typedFuncs) <- typeGlobs library globs + let vars = reverse typedVars + let funcDecs = typedFuncs ++ predefFuncs + (globvars,funcs,_,_) <- foldM (validGlob library vars funcDecs) ([],[],[],[]) globs + validStates snames [] vars funcDecs states + return (CompiledLSLScript (reverse globvars) funcs states) + where snames = let sname (State cn _) = ctxItem cn in map sname states +validGlob _ vars funcDecs (globvars,funcs,imports,namesUsed) (GV v mexpr) = + do when (isConstant $ varName v') $ throwError [(srcCtx v, varName v' ++ " is a predefined constant")] + -- find the vars that are defined prior to this global variable -- only one of these + -- vars may be used to initialize the global variable. + when (varName v' `elem` namesUsed) $ throwError [(srcCtx v, varName v' ++ " is already defined")] + let (vars',_) = break (\ var -> varName var == varName v') vars + case mexpr of + Nothing -> return (GDecl v' Nothing:globvars,funcs,imports, (varName v'):namesUsed) + Just expr -> do + t <- validCtxSimple vars' expr + let vt = varType v' + when (not (matchTypes vt t)) $ throwError [(srcCtx expr, "expression not of the correct type")] + return ((GDecl v' $ Just (ctxItem expr)):globvars,funcs,imports, (varName v'):namesUsed) + where v' = ctxItem v +validGlob _ vars funcDecs (globvars,funcs,imports,namesUsed) (GF f@(Func (FuncDec name t params) statements)) = + do noDupVars [] params + when (ctxItem name `elem` namesUsed) $ throwError [(srcCtx name, ctxItem name ++ " is already defined")] + returns <- validStatements False [] funcDecs vars t [] [[],params'] statements + when (not returns && t /= LLVoid) $ + throwError [(srcCtx name, "function " ++ (ctxItem name) ++ ": not all code paths return a value")] + return (globvars,f:funcs,imports,(ctxItem name):namesUsed) + where params' = ctxItems params +validGlob library vars funcDecs vstate@(globvars,funcs,imports,namesUsed) (GI (Ctx ctx name) bindings prefix) = + let context = incontext' (ctx,"module " ++ name) in + do let imp = (name,sort bindings,prefix) + if imp `elem` imports + then return (globvars,funcs,imports,namesUsed) + else context $ do + (LModule globs freevars) <- context $ lookupModule name library + context $ validBindings vars freevars bindings + (vars',funcDecs') <- context $ typeGlobs library globs + let renames = bindings ++ (map (\ x -> (x,prefix ++ x)) ((map varName vars') ++ (funcNames funcDecs'))) + (gvs,fs,imports',namesUsed') <- foldM (rewriteGlob prefix library renames ((map ctxItem freevars) ++ vars')) vstate globs + return (gvs,fs,imp:imports',namesUsed') + +rewriteGlob _ _ renames vars (globvars,funcs,imports,namesUsed) (GF (Func (FuncDec name t params) statements)) = + do name' <- incontext (srcCtx name, "renaming function " ++ ctxItem name ++ ", " ++ show renames) $ lookupM (ctxItem name) renames + when (name' `elem` namesUsed) $ throwStrError (name' ++ " imported from module is already defined") + let rewrittenFunc = (Func (FuncDec (Ctx (srcCtx name) name') t params) $ rewriteStatements 0 renames statements) + return (globvars,rewrittenFunc:funcs,imports,name':namesUsed) +rewriteGlob _ _ renames vars (globvars,funcs,imports,namesUsed) (GV (Ctx ctx (Var name t)) mexpr) = + do name' <- incontext (ctx,"renaming variable " ++ name) $ lookupM name renames + when (name' `elem` namesUsed) $ throwStrError (name' ++ " imported from module is already defined") + let rewrittenGlobVar = GDecl (Var name' t) $ + case mexpr of + Nothing -> Nothing + Just expr -> Just $ (ctxItem (rewriteCtxExpr renames expr)) + return (rewrittenGlobVar:globvars,funcs,imports,name':namesUsed) +rewriteGlob prefix0 library renames vars vstate@(globvars,funcs,imports,namesUsed) (GI (Ctx ctx mName) bindings prefix) = + do (LModule globs freevars) <- incontext (ctx, "rewriting module " ++ mName) $ lookupModule mName library + incontext (ctx,"") $ validBindings vars freevars bindings + bindings' <- mapM rewriteBinding bindings + let imp = (mName,sort bindings',prefix0 ++ prefix) + if (imp `elem` imports) + then return (globvars,funcs,imports,namesUsed) + else do + (vars',funcDecs') <- typeGlobs library globs + let renames = bindings' ++ map (\ x -> (x,prefix0 ++ prefix ++ x)) (map varName vars' ++ map (ctxItem . funcName) funcDecs') + (gvs,fs,imports',namesUsed') <- foldM (rewriteGlob (prefix0 ++ prefix) library renames vars') vstate globs + return (gvs,fs,imp:imports',namesUsed') + where rewriteBinding (fv,rn) = lookupM rn renames >>= return . ((,) fv) + +validBindings vars freevars bindings = + if length freevars /= length bindings then + throwStrError ("wrong number of bindings in import: " ++ (show $ length freevars) ++ " required") + else let f [] = return () + f ((x,y):xys) = + case (findType x (ctxItems freevars), findType y vars) of + (Nothing,_) -> throwStrError ("free variable " ++ x ++ " not found") + (_,Nothing) -> throwStrError ("global variable " ++ y ++ " not found") + (Just t0,Just t1) | not (matchTypes t0 t1) -> throwStrError ("types of " ++ x ++ " and " ++ y ++ " don't match") + | otherwise -> f xys + in f bindings + +validState snames used vars funcs (State (Ctx ctx name) handlers) = + do when (name `elem` used) $ throwError [(ctx, name ++ " already used")] + incontext (ctx,"") $ validHandlers snames [] funcs vars handlers + return name + +validStates snames used vars funcs [] = return () +validStates snames used vars funcs (s:ss) = + do name <- validState snames used vars funcs s + validStates snames (name:used) vars funcs ss + +validCast t0 t1 = + let validCasts = [(LLInteger,LLFloat), (LLFloat,LLInteger), + (LLInteger,LLString),(LLString,LLInteger), + (LLFloat,LLString),(LLString,LLFloat), + (LLString,LLVector),(LLVector,LLString), + (LLString,LLKey),(LLKey,LLString), + (LLRot,LLString),(LLString,LLRot), + (LLList,LLString),(LLString,LLList)] in + do when (t0 /= t1 && (t0,t1) `notElem` validCasts) $ throwStrError ("can't cast from " ++ (lslTypeString t0) ++ " to " ++ (lslTypeString t1)) + +validCtxSimple :: [Var] -> Ctx Expr -> Validity LSLType +validCtxSimple vars (Ctx ctx expr) = incontext (ctx,"") $ validSimple vars expr + +validSimple :: [Var] -> Expr -> Validity LSLType +validSimple vars (IntLit i) = return LLInteger +validSimple vars (FloatLit f) = return LLFloat +validSimple vars (StringLit s) = return LLString +validSimple vars (KeyLit k) = return LLKey +validSimple vars (Get (Ctx ctx name,All)) = + (do (Var _ t) <- incontext (ctx, "variable " ++ name) $ findM (\ v -> varName v == name) vars + return t) + `mplus` (findConstType name) +validSimple vars (Get (Ctx ctx name,_)) = throwError [(ctx,"can't access vector/rotation component in global variable initialization")] +validSimple vars (ListExpr []) = return LLList +validSimple vars (ListExpr (e:es)) = + do t <- validCtxSimple vars e + when (t == LLList) $ throwError [(srcCtx e,"lists cannot contain other lists")] + validSimple vars (ListExpr es) +validSimple vars (VecExpr e1 e2 e3) = validSimpleStructure vars LLVector [e1,e2,e3] +validSimple vars (RotExpr e1 e2 e3 e4) = validSimpleStructure vars LLRot [e1,e2,e3,e4] +validSimple vars (Neg e) = + do t <- validCtxSimple vars e + when (t `notElem` [LLFloat, LLInteger]) $ throwError [(srcCtx e,"operator only applicable to integers and floats in this context")] + return t +validSimple vars e = throwStrError ("expression is not valid in a static context.") + +validSimpleStructure vars t [] = return t +validSimpleStructure vars t (e:es) = + do t' <- validCtxSimple vars e + when (t' `notElem` [LLFloat,LLInteger]) $ throwError [(srcCtx e, "literal of type " ++ + (lslTypeString t') ++ " not a valid element of " ++ (lslTypeString t))] + validSimpleStructure vars t es + +validExpression :: Expr -> [FuncDec] -> [Var] -> [[Var]] -> Validity LSLType +validExpression (Cast t expr) funcs vars locals = + do t' <- validCtxExpr expr funcs vars locals + incontext (srcCtx expr, "") $ validCast t' t + return t +validExpression (Get ((Ctx ctx name),component)) funcs vars locals = + case (findType name (concat locals ++ vars) `mplus` findConstType name,component) of + (Nothing,_) -> throwError [(ctx, "undefined variable or constant: " ++ name)] + (Just LLRot,All) -> return LLRot + (Just LLRot,_) -> return LLFloat + (Just LLVector,All) -> return LLVector + (Just LLVector,S) -> throwError [(ctx,"s is not a valid component of a vector")] + (Just LLVector,_) -> return LLFloat + (Just t,All) -> return t + (Just t,_) -> throwError [(ctx,"only vectors and rotations have components")] +validExpression (Call name exprs) funcs vars locals = validCall funcs vars locals name exprs +validExpression (Not expr) funcs vars locals = + do t <- validCtxExpr expr funcs vars locals + when (t /= LLInteger) $ throwError [(srcCtx expr, "expression is not an integer expression, which is required for applying the Not operator")] + return t +validExpression (Neg expr) funcs vars locals = + do t <- validCtxExpr expr funcs vars locals + when (t == LLList) $ throwError [(srcCtx expr, "operator not applicable to list type")] + return t +validExpression (Inv expr) funcs vars locals = + do t <- validCtxExpr expr funcs vars locals + when (t /= LLInteger) $ throwError [(srcCtx expr, "expression is not an integer expression, which is required for applying the inverse operator")] + return t +validExpression plus@(Add expr1 expr2) funcs vars locals = + do (t1,t2) <- validEach (expr1,expr2) funcs vars locals + case (t1,t2) of + (LLInteger,LLInteger) -> return LLInteger + (LLInteger,LLFloat) -> return LLFloat + (LLFloat,LLInteger) -> return LLFloat + (LLFloat,LLFloat) -> return LLFloat + (LLVector,LLVector) -> return LLVector + (LLRot,LLRot) -> return LLRot + (LLString,LLString) -> return LLString + (LLList,LLList) -> return LLList + (t,LLList) -> return LLList + (LLList,t) -> return LLList + (t0,t1) -> incompatibleOperands plus t0 t1 +validExpression minus@(Sub expr1 expr2) funcs vars locals = + do (t1,t2) <- validEach (expr1,expr2) funcs vars locals + case (t1,t2) of + (LLInteger,LLInteger) -> return LLInteger + (LLInteger,LLFloat) -> return LLFloat + (LLFloat,LLInteger) -> return LLFloat + (LLFloat,LLFloat) -> return LLFloat + (LLVector,LLVector) -> return LLVector + (LLRot,LLRot) -> return LLRot + (t0,t1) -> incompatibleOperands minus t0 t1 +validExpression expr@(Mul expr1 expr2) funcs vars locals= + do (t1,t2) <- validEach (expr1,expr2) funcs vars locals + case (t1,t2) of + (LLInteger,LLInteger) -> return LLInteger + (LLInteger,LLFloat) -> return LLFloat + (LLFloat,LLInteger) -> return LLFloat + (LLFloat,LLFloat) -> return LLFloat + (LLVector,LLInteger) -> return LLVector + (LLVector,LLFloat) -> return LLVector + (LLFloat,LLVector) -> return LLVector + (LLInteger,LLVector) -> return LLVector + (LLVector,LLVector) -> return LLFloat + (LLVector,LLRot) -> return LLVector + (LLRot,LLRot) -> return LLRot + (t0,t1) -> incompatibleOperands expr t0 t1 +validExpression expr@(Div expr1 expr2) funcs vars locals = + do (t1,t2) <- validEach (expr1,expr2) funcs vars locals + case (t1,t2) of + (LLInteger,LLInteger) -> return LLInteger + (LLInteger,LLFloat) -> return LLFloat + (LLFloat,LLInteger) -> return LLFloat + (LLFloat,LLFloat) -> return LLFloat + (LLVector,LLInteger) -> return LLVector + (LLVector,LLFloat) -> return LLVector + (LLVector,LLRot) -> return LLVector + (LLRot,LLRot) -> return LLRot + (t0,t1) -> incompatibleOperands expr t0 t1 +validExpression expr@(Mod expr1 expr2) funcs vars locals = + do (t1,t2) <- validEach (expr1,expr2) funcs vars locals + case (t1,t2) of + (LLInteger,LLInteger) -> return LLInteger + (LLVector,LLVector) -> return LLVector + _ -> incompatibleOperands expr t1 t2 +validExpression e@(Equal expr1 expr2) funcs vars locals = + do (t1,t2) <- validEach (expr1,expr2) funcs vars locals + case (t1,t2) of + (LLInteger,LLFloat) -> return LLInteger + (LLFloat,LLInteger) -> return LLInteger + (LLString,LLKey) -> return LLInteger + (LLKey,LLString) -> return LLInteger + (t1,t2) | (t1 == t2) -> return LLInteger + | otherwise -> incompatibleOperands e t1 t2 +validExpression e@(NotEqual expr1 expr2) funcs vars locals = + do (t1,t2) <- validEach (expr1,expr2) funcs vars locals + case (t1,t2) of + (LLInteger,LLFloat) -> return LLInteger + (LLFloat,LLInteger) -> return LLInteger + (LLString,LLKey) -> return LLInteger + (LLKey,LLString) -> return LLInteger + (t1,t2) | (t1 == t2) -> return LLInteger + | otherwise -> incompatibleOperands e t1 t2 +validExpression e@(BAnd expr1 expr2) funcs vars locals = validBothInteger (expr1,expr2) funcs vars locals +validExpression e@(BOr expr1 expr2) funcs vars locals = validBothInteger (expr1,expr2) funcs vars locals +validExpression e@(Xor expr1 expr2) funcs vars locals = validBothInteger (expr1,expr2) funcs vars locals +validExpression e@(ShiftL expr1 expr2) funcs vars locals = validBothInteger (expr1,expr2) funcs vars locals +validExpression e@(ShiftR expr1 expr2) funcs vars locals = validBothInteger (expr1,expr2) funcs vars locals +validExpression e@(Gt expr1 expr2) funcs vars locals = validRelExpr (expr1,expr2) funcs vars locals +validExpression e@(Ge expr1 expr2) funcs vars locals = validRelExpr (expr1,expr2) funcs vars locals +validExpression e@(Le expr1 expr2) funcs vars locals = validRelExpr (expr1,expr2) funcs vars locals +validExpression e@(Lt expr1 expr2) funcs vars locals = validRelExpr (expr1, expr2) funcs vars locals +validExpression e@(And expr1 expr2) funcs vars locals = validBothInteger (expr1, expr2) funcs vars locals +validExpression e@(Or expr1 expr2) funcs vars locals = validBothInteger (expr1, expr2) funcs vars locals +validExpression e@(IncBy (name,All) expr) funcs vars locals = + do failIfNoModify name + (t1,t2) <- validNameExpr (name,expr) funcs vars locals + case (t1,t2) of + (LLInteger,LLInteger) -> return LLInteger + (LLFloat,LLInteger) -> return LLFloat + (LLFloat,LLFloat) -> return LLFloat + (LLVector,LLVector) -> return LLVector + (LLRot,LLRot) -> return LLRot + (LLString,LLString) -> return LLString + (LLList,LLList) -> return LLList + (LLList,t) -> return LLList + (t0,t1) -> incompatibleOperands e t0 t1 +validExpression e@(IncBy (name,_) expr) funcs vars locals = + do failIfNoModify name + (t1,t2) <- validNameExpr (name,expr) funcs vars locals + case (t1,t2) of + (t1,t2) | t1 `elem` [LLVector,LLRot] && t2 `elem` [LLFloat,LLInteger] -> return LLFloat + | otherwise -> incompatibleOperands e t1 t2 +validExpression e@(DecBy (name,All) expr) funcs vars locals = + do failIfNoModify name + (t1,t2) <- validNameExpr (name,expr) funcs vars locals + case (t1,t2) of + (LLInteger,LLInteger) -> return LLInteger + (LLFloat,LLInteger) -> return LLFloat + (LLFloat,LLFloat) -> return LLFloat + (LLVector,LLVector) -> return LLVector + (LLRot,LLRot) -> return LLRot + (t0,t1) -> incompatibleOperands e t0 t1 +validExpression e@(DecBy (name,_) expr) funcs vars locals = + do failIfNoModify name + (t1,t2) <- validNameExpr (name,expr) funcs vars locals + case (t1,t2) of + (t1,t2) | t1 `elem` [LLVector,LLRot] && t2 `elem` [LLFloat,LLInteger] -> return LLFloat + | otherwise -> incompatibleOperands e t1 t2 +validExpression e@(MulBy (name,All) expr) funcs vars locals = + do failIfNoModify name + (t1,t2) <- validNameExpr (name,expr) funcs vars locals + case (t1,t2) of + (LLInteger,LLInteger) -> return LLInteger + (LLFloat,LLInteger) -> return LLFloat + (LLFloat,LLFloat) -> return LLFloat + (LLVector,LLInteger) -> return LLVector + (LLVector,LLFloat) -> return LLVector + (LLVector,LLVector) -> return LLVector -- note: LSL compiles this, but it results in runtime error! + (LLVector,LLRot) -> return LLVector + (LLRot,LLRot) -> return LLRot + (t0,t1) -> incompatibleOperands e t0 t1 +validExpression e@(MulBy (name,_) expr) funcs vars locals = + do failIfNoModify name + (t1,t2) <- validNameExpr (name,expr) funcs vars locals + case (t1,t2) of + (t1,t2) | t1 `elem` [LLVector,LLRot] && t2 `elem` [LLFloat,LLInteger] -> return LLFloat + | otherwise -> incompatibleOperands e t1 t2 +validExpression e@(DivBy (name,All) expr) funcs vars locals = + do failIfNoModify name + (t1,t2) <- validNameExpr (name,expr) funcs vars locals + case (t1,t2) of + (LLInteger,LLInteger) -> return LLInteger + (LLFloat,LLInteger) -> return LLFloat + (LLFloat,LLFloat) -> return LLFloat + (LLVector,LLInteger) -> return LLVector + (LLVector,LLFloat) -> return LLVector + (LLVector,LLRot) -> return LLVector + (LLRot,LLRot) -> return LLRot + (t0,t1) -> incompatibleOperands e t0 t1 +validExpression e@(DivBy (name,_) expr) funcs vars locals = + do failIfNoModify name + (t1,t2) <- validNameExpr (name,expr) funcs vars locals + case (t1,t2) of + (t1,t2) | t1 `elem` [LLVector,LLRot] && t2 `elem` [LLFloat,LLInteger] -> return LLFloat + | otherwise -> incompatibleOperands e t1 t2 +validExpression e@(ModBy (name,All) expr) funcs vars locals = + do failIfNoModify name + (t1,t2) <- validNameExpr (name,expr) funcs vars locals + case (t1,t2) of + (LLInteger,LLInteger) -> return LLInteger + (LLVector,LLVector) -> return LLVector + (t0,t1) -> incompatibleOperands e t0 t1 +validExpression e@(ModBy (name,_) expr) funcs vars locals = + do failIfNoModify name + (t1,t2) <- validNameExpr (name,expr) funcs vars locals + case (t1,t2) of + (t1,t2) -> incompatibleOperands e t1 t2 +validExpression e@(PostInc var) funcs vars locals = validIncDecOp var vars locals "++" +validExpression e@(PostDec var) funcs vars locals = validIncDecOp var vars locals "--" +validExpression e@(PreInc var) funcs vars locals = validIncDecOp var vars locals "++" +validExpression e@(PreDec var) funcs vars locals = validIncDecOp var vars locals "++" +validExpression expr0@(Set (name,All) expr) funcs vars locals = + do failIfNoModify name + (t1,t2) <- validNameExpr (name,expr) funcs vars locals + case (t1,t2) of + (LLFloat,LLInteger) -> return LLFloat + (LLKey,LLString) -> return LLKey + (LLString,LLKey) -> return LLString + (t1,t2) | t1 == t2 -> return t1 + | otherwise -> incompatibleOperands expr0 t1 t2 +validExpression expr0@(Set (name,S) expr) funcs vars locals = + do failIfNoModify name + (t1,t2) <- validNameExpr (name,expr) funcs vars locals + case (t1,t2) of + (LLRot,LLFloat) -> return LLFloat + (LLRot,LLInteger) -> return LLFloat + (t0,t1) -> incompatibleOperands expr0 t0 t1 +validExpression expr0@(Set (name,_) expr) funcs vars locals = + do failIfNoModify name + (t1,t2) <- validNameExpr (name,expr) funcs vars locals + case (t1,t2) of + (LLVector,LLFloat) -> return LLFloat + (LLVector,LLInteger) -> return LLFloat + (LLRot,LLFloat) -> return LLFloat + (LLRot,LLInteger) -> return LLFloat + (t0,t1) -> incompatibleOperands expr0 t0 t1 +validExpression (IntLit i) _ _ _ = return LLInteger +validExpression (FloatLit _) _ _ _ = return LLFloat +validExpression (StringLit _) _ _ _ = return LLString +validExpression (KeyLit _) _ _ _ = return LLKey +validExpression (ListExpr es) fs vs ls = do + mapM (\ e -> validListExprElement e fs vs ls) es + return LLList +validExpression (VecExpr xExpr yExpr zExpr) funcs vars locals = + do xt <- validCtxExpr xExpr funcs vars locals + yt <- validCtxExpr yExpr funcs vars locals + zt <- validCtxExpr zExpr funcs vars locals + when (not (all (`elem` [LLInteger,LLFloat]) [xt,yt,zt])) $ throwStrError "invalid components for vector" + return LLVector +validExpression (RotExpr xExpr yExpr zExpr sExpr) funcs vars locals = + do xt <- validCtxExpr xExpr funcs vars locals + yt <- validCtxExpr yExpr funcs vars locals + zt <- validCtxExpr zExpr funcs vars locals + st <- validCtxExpr sExpr funcs vars locals + when (not (all (`elem` [LLInteger,LLFloat]) [xt,yt,zt,st])) $ throwStrError "invalid components for rotation" + return LLRot +--validExpression x funcs vars locals = error ("what to do with " ++ (show x)) + +validListExprElement (Ctx ctx e) funcs vars locals = do + t <- validExpression e funcs vars locals + when (t `elem` [LLVoid,LLList]) $ throwError [(ctx,"invalid type for list element")] + return () + +validMExpression Nothing funcs vars locals = return LLVoid +validMExpression (Just expr) funcs vars locals = validCtxExpr expr funcs vars locals + +validExpressions es funcs vars locals = mapM_ (\ e -> validCtxExpr e funcs vars locals) es + +validRelExpr (expr1,expr2) funcs vars locals = + do (t1,t2) <- validEach (expr1,expr2) funcs vars locals + case (t1,t2) of + (LLInteger,LLInteger) -> return LLInteger + (LLInteger,LLFloat) -> return LLInteger + (LLFloat, LLInteger) -> return LLInteger + (LLFloat, LLFloat) -> return LLInteger + (t0,t1) -> throwStrError ("operands are of incompatible types") +validBothInteger (expr1, expr2) funcs vars locals = + do (t1,t2) <- validEach (expr1,expr2) funcs vars locals + when (t1 /= LLInteger || t2 /= LLInteger) $ throwStrError ("operands are of incompatible types") + return LLInteger +validEach (expr1, expr2) funcs vars locals = + do t1 <- validCtxExpr expr1 funcs vars locals + t2 <- validCtxExpr expr2 funcs vars locals + return (t1,t2) + +validNameExpr (Ctx ctx name, expr) funcs vars locals = + case (findType name (concat locals ++ vars), + validCtxExpr expr funcs vars locals) of + (Just t1, Right t2) -> return (t1,t2) + (Nothing, _) -> throwError [(ctx, "variable " ++ name ++ " not defined")] + (_,Left s) -> throwError s +validCall funcs vars locals (Ctx ctx fname) exprs = + do (FuncDec _ t params) <- findFuncDec fname funcs + let vArg _ [] [] = return () + vArg _ (p:ps) [] = throwError [(ctx, "mismatch of arguments vs. formal paramters in call to function " ++ fname)] + vArg _ [] (a:as) = throwError [(ctx, "mismatch of arguments vs. formal paramters in call to function " ++ fname)] + vArg n (Var name t:ts) (arg:args) = + do t' <- validCtxExpr arg funcs vars locals + when (not (matchTypes t t')) $ throwError [(ctx, "argument " ++ (show n) ++ " in call to function (" ++ fname ++ ") is of wrong type:" ++ (lslTypeString t') ++ ", should be " ++ (lslTypeString t))] + vArg (n+1) ts args + vArg 1 (ctxItems params) exprs + return t + +validCtxExpr (Ctx ctx e) fs vs ls = incontext (ctx,"") $ validExpression e fs vs ls + +validIncDecOp (n@(Ctx ctx name),c) vars locals op = + do failIfNoModify n + case (findType name (concat locals ++ vars),c) of + (Nothing,_) -> throwError [(ctx, "variable " ++ name ++ " not found")] + (Just LLInteger,All) -> return LLInteger + (Just LLFloat,All) -> return LLFloat + (Just LLRot,S) -> return LLFloat + (Just LLVector,S) -> throwError [(ctx, "s is not a valid component of " ++ name)] + (Just t,All) -> throwError [(ctx, name ++ " is not a valid operand for " ++ op)] + (Just LLVector,_) -> return LLFloat + (Just LLRot,_) -> return LLFloat + _ -> throwError [(ctx, name ++ " is not a valid operand for " ++ op)] + +failIfNoModify (Ctx ctx name) = + when (isConstant name) $ throwError [(ctx,"cannot modify " ++ name ++ " because it is a constant")] + +incompatibleOperands expr t0 t1 = + throwStrError ("types of the operands aren't compatible (" ++ + (lslTypeString t0) ++ " vs. " ++ (lslTypeString t1) ++ ")") + +defined :: String -> [Var] -> Bool +defined n = any (\ (Var n' _) -> n == n') + +validStatement _ _ funcs vars rtype labels locals@(scope:scopes) returns (Decl var@(Var name t) expr) = + do when (defined name $ concat locals) $ throwStrError ("variable " ++ name ++ " already defined") -- can't hide another local, even in a surrounding scope + when (isConstant name) $ throwStrError ("variable " ++ name ++ " is a predefined constant") + case expr of + Nothing -> return ((var:scope):scopes,returns) + Just expr' -> do t' <- validCtxExpr expr' funcs vars locals + when (not $ matchTypes t t') $ throwError [(srcCtx expr', "type of expression in declaration of " ++ name ++ " does not match " ++ lslTypeString t)] + return ((var:scope):scopes,returns) +validStatement scallow snames funcs vars rtype labels locals returns (While expr statement) = + do t <- validCtxExpr expr funcs vars locals + --when (t /= LLInteger) $ throwError [(srcCtx expr, "expression is not a valid loop condition")] + validStatement scallow snames funcs vars rtype labels locals False statement + return (locals,returns) +validStatement scallow snames funcs vars rtype labels locals returns (DoWhile statement expr) = + do t <- validCtxExpr expr funcs vars locals + --when (t /= LLInteger) $ throwError [(srcCtx expr, "expression is not a valid loop condition")] + validStatement scallow snames funcs vars rtype labels locals False statement + return (locals,returns) +validStatement scallow snames funcs vars rtype labels locals returns (For mexpr1 mexpr2 mexpr3 statement) = + do validExpressions mexpr1 funcs vars locals + validExpressions mexpr3 funcs vars locals + t <- validMExpression mexpr2 funcs vars locals + --when (t /= LLInteger) $ throwStrError ("expression is not a valid loop condition") + validStatement scallow snames funcs vars rtype labels locals False statement + return (locals,returns) +validStatement scallow snames funcs vars rtype labels locals returns (If expr thenStmt elseStmt) = + do t <- validCtxExpr expr funcs vars locals + --when (t /= LLInteger) $ throwError [(srcCtx expr, "expression is not a valid 'if' condition")] + (_,ret1) <- validStatement scallow snames funcs vars rtype labels locals False thenStmt + (_,ret2) <- validStatement scallow snames funcs vars rtype labels locals False elseStmt + return (locals,returns || ret1 && ret2) +validStatement _ _ _ _ _ _ locals returns NullStmt = return (locals,returns) +validStatement _ _ funcs vars rtype labels locals _ (Return Nothing) = + do when (rtype /= LLVoid) (throwStrError "function must return a value") + return (locals,True) +validStatement _ _ funcs vars rtype labels locals _ (Return (Just expr)) = + do t <- validCtxExpr expr funcs vars locals + when (t /= rtype && not (all (`elem` [LLString,LLKey]) [t,rtype])) (throwStrError "inappropriate return type for function/handler") + return (locals,True) +validStatement scallow snames funcs vars rtype labels locals returns (StateChange name) = do + when (not scallow) $ throwStrError "state changes not allowed from this context" + when (not (name `elem` snames)) $ throwStrError (name ++ " is not a valid state") + return (locals,returns) +validStatement _ _ funcs vars rtype labels locals returns (Do expr) = validCtxExpr expr funcs vars locals>>return (locals,returns) +validStatement scallow snames funcs vars rtype labels locals returns (Compound stmts) = + do returns' <- validStatements scallow snames funcs vars rtype labels ([]:locals) stmts + return (locals,returns || returns') +validStatement _ _ funcs vars rtype labels locals _ (Label _) = return (locals,False) +validStatement _ _ funcs vars rtype labels locals returns (Jump s) = + do when (s `notElem` concat labels) $ throwStrError ("no such label to jump to: " ++ s) + return (locals,returns) + +validStatement' scallow snames funcs vars rtype labels locals returns line (Ctx ctx stmt) = + incontext (ctx, "") $ validStatement scallow snames funcs vars rtype labels locals returns stmt + +validStatements :: Bool -> [String] -> [FuncDec] -> [Var] -> LSLType -> [[String]] -> [[Var]] -> [CtxStmt] -> Validity Bool +validStatements scallow snames funcs vars rtype labels locals stmts = + do let newLabels = map (\ (Label s) -> s) $ filter isLabel (ctxItems stmts) + (_,r') <- foldM (\ (l,r) (n, s) -> + validStatement' scallow snames funcs vars rtype (newLabels:labels) l r n s) (locals,False) $ zip ([1..]::[Int]) stmts + return r' + +validHandler snames used funcs vars (Handler (Ctx ctx name) args stmts) = + do when (name `elem` used) $ throwError [(ctx,name ++ " already used in state")] + types <- incontext (ctx,"handler: ") $ lookupM name goodHandlers + when (types /= map varType args') $ throwError [(ctx,"invalid argument types for handler " ++ name)] + when (length args /= (length $ nub $ map varName args')) $ throwError [(ctx,"not all argument names are unique for handler " ++ name)] + validStatements True snames funcs vars LLVoid [] [[],args'] stmts + return name + where args' = ctxItems args + +validHandlers _ _ _ _ [] = return () +validHandlers snames used funcs vars (h:hs) = + do name <- validHandler snames used funcs vars h + validHandlers snames (name:used) funcs vars hs + +-- Validating a library of modules + +compileModule :: LModule -> VState (Validity ([Global],[Func])) +compileModule m@(LModule globs freevars) = do + mapM_ (vsmAddGV . ctxItem) freevars + preprocessGlobDefs_ "" globs + mapM_ vsmAddGF predefFuncs + mapM_ compileGlob globs + errs <- get'vsErr + case errs of + [] -> do + globals <- get'vsGlobals + funcs <- get'vsFuncs + return $ Right $ (globals,funcs) + _ -> return $ Left errs +-- +validModule library m@(LModule globs freevars) = + do --used <- noDupGlobs Nothing "" [] library globs + (typedVars, typedFuncs) <- typeGlobs library globs + let used = (map varName typedVars) ++ (map (ctxItem . funcName) typedFuncs) + noDupVars used freevars + let vars = freevars' ++ reverse typedVars + let funcDecs = typedFuncs ++ predefFuncs + (vs,fs,_,_) <- foldM (validGlob library vars funcDecs) ([],[],[],[]) globs + return (vs,fs) + where freevars' = ctxItems freevars + +-- this function isn't partiuclarly efficient! +moduleDependencies lib chain m = + let f (GI s _ _) = Just (ctxItem s) + f _ = Nothing + in do (LModule globs _) <- lookupM m lib + case filtMap f globs of + [] -> return [] + list -> if any (`elem` list) (m:chain) then throwStrError "circular dependency" + else + do deps <- fmap concat ( + let chain' = (m:chain) in + mapM (moduleDependencies lib chain') list) + return $ nub (list ++ deps) + +-- sort modules by dependency: for each module in the list, after sorting that module +-- will depend only on modules preceding it in the list. This of course implies that +-- there can be no circular dependencies in the modules. +sortModules :: [(String,(LModule,[String]))] -> [(String,LModule)] +sortModules modules = + let cmp (name,(_,deplist)) (name',(_,deplist')) = compare (length deplist, name) (length deplist', name') + sort1 [] = [] + sort1 list = + let sorted = sortBy cmp list + (nodeps,deps) = span ((==0).length.snd.snd) sorted + exclude = map fst nodeps + newlist = if length nodeps == 0 then error "circular depencencies in library" + else map (\ (nm,(m,l)) -> (nm, (m,filter (`notElem` exclude) l))) deps + in nodeps ++ sort1 newlist + in map (\ (s,(m,_)) -> (s,m)) $ sort1 modules + +compileLibrary :: [(String,LModule)] -> [(String,Validity (LModule,ModuleInfo))] +compileLibrary modules = + let checkDep (n,m) = case moduleDependencies modules [] n of + Right deps -> (n,Right (m,deps)) + Left s -> (n,Left s) + categorize (good,bad) (n,Left s) = (good,(n,s):bad) + categorize (good,bad) (n,Right (m,deps)) = ((n,(m,deps)):good,bad) + (good,bad) = foldl categorize ([],[]) $ map checkDep modules + sorted = sortModules good + validate augLib (name,m) = + case evalState (compileModule m) (emptyValidationState { vsLib = libFromAugLib augLib }) of + Left s -> (name, Left s):augLib + Right gs -> (name,Right (m,gs)):augLib + in (foldl validate [] sorted) ++ (map (\ (n,s) -> (n,Left s)) bad) + +validLibrary modules = + let checkDep (n,m) = case moduleDependencies modules [] n of + Right deps -> (n,Right (m,deps)) + Left s -> (n,Left s) + categorize (good,bad) (n,Left s) = (good,(n,s):bad) + categorize (good,bad) (n,Right (m,deps)) = ((n,(m,deps)):good,bad) + (good,bad) = foldl categorize ([],[]) $ map checkDep modules + sorted = sortModules good + validate augLib (name,m) = + case validModule (libFromAugLib augLib) m of + Left s -> (name, Left s):augLib + Right gs -> (name,Right (m,gs)):augLib + in (foldl validate [] sorted) ++ (map (\ (n,s) -> (n,Left s)) bad) + +libFromAugLib :: AugmentedLibrary -> Library +libFromAugLib augLib = + let f (name,Left s) = (name,Left s) + f (name,Right (lm,_)) = (name, Right lm) + in map f augLib + +tstLib = [ + ("alpha", LModule [GI (nullCtx "beta") [] []] []), + ("beta", LModule [GI (nullCtx "gamma") [] []] []), + ("gamma", LModule [GI (nullCtx "alpha") [] []] []), + ("omega", LModule [GI (nullCtx "lambda") [] []] []), + ("lambda", LModule [GI (nullCtx "kappa") [] [], GI (nullCtx "sigma") [] []] []), + ("kappa", LModule [] []), + ("sigma", LModule [] [])] + +-- | Transform a script into a module, generating function names for each handler, using the +-- pattern _state_. +-- The script following script: +-- +-- default { +-- state_entry() { +-- llSay(0,"Hello Avatar"); +-- } +-- } +-- +-- would be transformed into a module equivalent to: +-- +-- $module +-- +-- default_state_state_entry() { +-- llSay(0,"Hello Avatar"); +-- } +moduleFromScript :: CompiledLSLScript -> LModule +moduleFromScript script = LModule globDefs [] + where globDefs = globDefsFromGlobs (scriptGlobals script) ++ + globDefsFromFuncs (scriptFuncs script) ++ + funcDefsFromStates (scriptStates script) + globDefsFromGlobs = map globDefFromGlob + globDefsFromFuncs = map GF + funcDefsFromStates = concatMap funcDefsFromState + +globDefFromGlob (GDecl v me) = GV (nullCtx v) (fmap nullCtx me) +funcDefsFromState (State ctxnm handlers) = map (funcDefFromHandler (ctxItem ctxnm)) handlers +funcDefFromHandler stateName (Handler ctxnm params stmts) = GF $ Func (FuncDec combinedName LLVoid params) stmts + where combinedName = nullCtx $ stateName ++ "$$" ++ (ctxItem ctxnm) + +rewriteCtxExpr :: [(String,String)] -> Ctx Expr -> Ctx Expr +rewriteCtxExpr renames = everywhere (mkT (rewriteName renames)) + +rewriteName :: [(String,String)] -> Ctx String -> Ctx String +rewriteName renames (Ctx ctx name) = + case lookup name renames of + Nothing -> Ctx ctx name + Just name' -> Ctx ctx name' +rewriteStatements _ _ [] = [] +rewriteStatements n bindings (Ctx c s:ss) = + let (n',bindings',s') = rewriteStatement n bindings s in + (Ctx c s'):(rewriteStatements n' bindings' ss) + +rewriteStatement n bindings (Compound stmts) = (n, bindings, Compound $ rewriteStatements n bindings stmts) +rewriteStatement n bindings (While expr stmt) = + let (_,_,stmt') = rewriteStatement n bindings stmt in + (n, bindings, While (rewriteCtxExpr bindings expr) stmt') +rewriteStatement n bindings (DoWhile stmt expr) = + let (_,_,stmt') = rewriteStatement n bindings stmt in + (n, bindings, DoWhile stmt' (rewriteCtxExpr bindings expr)) +rewriteStatement n bindings (For mexpr1 mexpr2 mexpr3 stmt) = + let (_,_,stmt') = rewriteStatement n bindings stmt + rewriteMExpr = rewriteMExpression bindings + rewriteEs = rewriteCtxExprs bindings in + (n, bindings, For (rewriteEs mexpr1) (rewriteMExpr mexpr2) (rewriteEs mexpr3) stmt') +rewriteStatement n bindings (If expr stmt1 stmt2) = + let (_,_,stmt1') = rewriteStatement n bindings stmt1 + (_,_,stmt2') = rewriteStatement n bindings stmt2 in + (n, bindings, If (rewriteCtxExpr bindings expr) stmt1' stmt2') +rewriteStatement n bindings (Decl (Var name t) val) = + let (n',bindings', newname) = + if any (\(name',_) -> name == name') bindings then let newname = "local" ++ (show n) in (n + 1, (name,newname):bindings, newname) + else (n,bindings,name) + in (n',bindings',Decl (Var newname t) (rewriteMExpression bindings val)) +rewriteStatement n bindings (Return Nothing) = (n, bindings, Return Nothing) +rewriteStatement n bindings (Return (Just expr)) = (n, bindings, Return $ Just $ rewriteCtxExpr bindings expr) +rewriteStatement n bindings (Do expr) = (n, bindings, Do $ rewriteCtxExpr bindings expr) +rewriteStatement n bindings s = (n, bindings, s) + +rewriteCtxExprs bindings ctxExprs = map (rewriteCtxExpr bindings) ctxExprs + +rewriteMExpression bindings = fmap (rewriteCtxExpr bindings) + + diff --git a/src/Language/Lsl/UnitTestEnv.hs b/src/Language/Lsl/UnitTestEnv.hs --- a/src/Language/Lsl/UnitTestEnv.hs +++ b/src/Language/Lsl/UnitTestEnv.hs @@ -121,7 +121,7 @@ Nothing -> return (Left $ "No such module: " ++ moduleName) Just (Left s) -> return (Left $ "Invalid module: " ++ moduleName) Just (Right lmodule) -> - case validLSLScript lib (mkScript lmodule) of + case compileLSLScript' lib (mkScript lmodule) of Left _ -> return $ Left "Invalid entry point (internal error?)" Right script -> return $ Right (script,[funcName]) @@ -203,7 +203,7 @@ in case init of (Left s, world') -> Left s (Right exec,world') -> - case (runState $ runErrorT $ (runStateT $ runErrorT $ evalSimple 1000) exec) world of + case (runState $ runErrorT $ (runStateT $ runErrorT $ evalSimple 10000) exec) world of (Left s,_) -> Left s (Right r, _) -> case r of diff --git a/src/Language/Lsl/WorldDef.hs b/src/Language/Lsl/WorldDef.hs --- a/src/Language/Lsl/WorldDef.hs +++ b/src/Language/Lsl/WorldDef.hs @@ -515,8 +515,8 @@ prim <- (lift . fctx ("looking up prim " ++ primKey ++ " failed")) (mlookup primKey primMap) when (isNothing (findByInvName invName (primInventory prim))) $ fail (invName ++ " doesn't exist in prim " ++ primKey) case script of - Left (_,s) -> tell [("script \"" ++ invName ++ "\" in prim " ++ primKey ++ " failed to activate because of error: " ++ s)] - >> return Nothing + Left ((_,s):_) -> tell [("script \"" ++ invName ++ "\" in prim " ++ primKey ++ " failed to activate because of error: " ++ s)] + >> return Nothing Right code -> return $ Just (k,mkScript $ initLSLScript code) newKey xref = do diff --git a/src/LslPlus.hs b/src/LslPlus.hs --- a/src/LslPlus.hs +++ b/src/LslPlus.hs @@ -12,7 +12,7 @@ import System import System.Exit -version="0.1.4" +version="0.2.0" usage progName = "Usage: " ++ progName ++ " [Version|MetaData|Compiler|ExpressionHandler|SimMetaData|SystemTester|UnitTester]" main = do progName <- getProgName @@ -32,4 +32,4 @@ val -> do hPutStrLn stderr ("Invalid argument: " ++ val) hPutStrLn stderr (usage progName) - exitFailure + exitFailure