zeolite-lang 0.11.0.0 → 0.12.0.0

raw patch · 26 files changed

+546/−169 lines, 26 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +55/−0
• lib/file/Category_RawFileReader.cpp +4/−4
• lib/file/Category_RawFileWriter.cpp +4/−4
• lib/math/Category_Math.cpp +6/−0
• lib/math/Source_Math.cpp +3/−1
• lib/math/Source_Math.hpp +1/−0
• lib/math/math.0rp +2/−0
• lib/math/tests.0rt +6/−0
• lib/util/Category_Argv.cpp +2/−2
• lib/util/Category_SimpleInput.cpp +2/−2
• lib/util/Category_SimpleOutput.cpp +3/−3
• src/Compilation/CompilerState.hs +6/−1
• src/Compilation/ProcedureContext.hs +29/−1
• src/CompilerCxx/Category.hs +13/−13
• src/CompilerCxx/Procedure.hs +87/−73
• src/Parser/DefinedCategory.hs +2/−4
• src/Parser/Procedure.hs +78/−24
• src/Test/Procedure.hs +21/−14
• src/Types/Procedure.hs +16/−1
• tests/cli-tests.sh +9/−1
• tests/conditionals.0rt +42/−2
• tests/infix-functions.0rt +33/−0
• tests/infix-operations.0rt +16/−2
• tests/regressions.0rt +83/−0
• tests/while.0rt +22/−16
• zeolite-lang.cabal +1/−1

@@ -1,5 +1,60 @@ # Revision history for zeolite-lang +## 0.12.0.0  -- 2020-12-11++### Language++* **[breaking]** Several more fixes for named returns:++  * **[new]** Allows *initialization* of named returns in `if`/`elif`/`while`+    predicates. Although *setting* a named return in a predicate has always been+    allowed, it previously did not count as an initialization for the purposes+    of checking usage in subsequent statements.++  * **[breaking]** Fixes a bug where named returns used in `if`/`elif`/`while`+    predicates inside of `cleanup` blocks were not getting checked for+    initialization. This turns a potential runtime error into a compile-time+    error, which could break buggy code that was never going to be executed.++  * **[fix]** Fixes a bug where a named return with a primitive type was not+    getting set in an explicit `return` statement. This only affected code that+    used primitive named returns inside of a `cleanup` block where the+    corresponding `in` block used an explicit `return` statement.++    ```text+    @type call () -> (Int)+    call () (x) {+      cleanup {+        \ foo(x)     // x was not getting set for this call+      } in return 1  // 1 was still returned from the function as expected+    }+    ```++    This *did not* affect non-primitive types such as `String` and user-defined+    `concrete` and `interface` categories.++* **[breaking]** Updates associativity of infix operators:++  * **[breaking]** Makes infix `Bool` operators `&&` and `||`+    *right-associative*. For example, `x && y && z` used to be parsed as+    `(x && y) && z`, whereas now it is parsed as `x && (y && z)`. This better+    reflects the intuition of side-effects happening in order, with respect to+    short-circuiting. (No other operators currently short-circuit.)++  * **[breaking]** Makes comparison operators (e.g., `<=`) *non-associative*.+    This means that expressions such as `x < y == true` will no longer compile.+    This is because an equivalent-looking expression `true == x < y` might have+    a different interpretation. (Note that order operators such as `<` *are not*+    defined for `Bool`, so something like `x < y < z` would have already failed+    previously.)++  All other infix operators (including infix function calls such as+  ``x `Math.pow` y``) remain *left-associative*.++### Libraries++  * **[new]** Adds `Math.abs` for `Int` absolute value to `lib/math`.+ ## 0.11.0.0  -- 2020-12-09  ### Compiler CLI

@@ -94,7 +94,7 @@       &Type_RawFileReader::Call_open,     };     if (label.collection == Functions_RawFileReader) {-      if (label.function_num < 0 || label.function_num >= 1) {+      if (label.function_num < 0 || label.function_num >= sizeof Table_RawFileReader / sizeof(CallType)) {         FAIL() << "Bad function call " << label;       }       return (this->*Table_RawFileReader[label.function_num])(self, params, args);@@ -124,19 +124,19 @@       &Value_RawFileReader::Call_getFileError,     };     if (label.collection == Functions_BlockReader) {-      if (label.function_num < 0 || label.function_num >= 2) {+      if (label.function_num < 0 || label.function_num >= sizeof Table_BlockReader / sizeof(CallType)) {         FAIL() << "Bad function call " << label;       }       return (this->*Table_BlockReader[label.function_num])(self, params, args);     }     if (label.collection == Functions_PersistentResource) {-      if (label.function_num < 0 || label.function_num >= 1) {+      if (label.function_num < 0 || label.function_num >= sizeof Table_PersistentResource / sizeof(CallType)) {         FAIL() << "Bad function call " << label;       }       return (this->*Table_PersistentResource[label.function_num])(self, params, args);     }     if (label.collection == Functions_RawFileReader) {-      if (label.function_num < 0 || label.function_num >= 1) {+      if (label.function_num < 0 || label.function_num >= sizeof Table_RawFileReader / sizeof(CallType)) {         FAIL() << "Bad function call " << label;       }       return (this->*Table_RawFileReader[label.function_num])(self, params, args);

@@ -94,7 +94,7 @@       &Type_RawFileWriter::Call_open,     };     if (label.collection == Functions_RawFileWriter) {-      if (label.function_num < 0 || label.function_num >= 1) {+      if (label.function_num < 0 || label.function_num >= sizeof Table_RawFileWriter / sizeof(CallType)) {         FAIL() << "Bad function call " << label;       }       return (this->*Table_RawFileWriter[label.function_num])(self, params, args);@@ -123,19 +123,19 @@       &Value_RawFileWriter::Call_getFileError,     };     if (label.collection == Functions_BlockWriter) {-      if (label.function_num < 0 || label.function_num >= 1) {+      if (label.function_num < 0 || label.function_num >= sizeof Table_BlockWriter / sizeof(CallType)) {         FAIL() << "Bad function call " << label;       }       return (this->*Table_BlockWriter[label.function_num])(self, params, args);     }     if (label.collection == Functions_PersistentResource) {-      if (label.function_num < 0 || label.function_num >= 1) {+      if (label.function_num < 0 || label.function_num >= sizeof Table_PersistentResource / sizeof(CallType)) {         FAIL() << "Bad function call " << label;       }       return (this->*Table_PersistentResource[label.function_num])(self, params, args);     }     if (label.collection == Functions_RawFileWriter) {-      if (label.function_num < 0 || label.function_num >= 1) {+      if (label.function_num < 0 || label.function_num >= sizeof Table_RawFileWriter / sizeof(CallType)) {         FAIL() << "Bad function call " << label;       }       return (this->*Table_RawFileWriter[label.function_num])(self, params, args);

@@ -191,6 +191,12 @@     const PrimFloat Var_arg1 = (args.At(0))->AsFloat();     return ReturnTuple(Box_Float(std::trunc(Var_arg1)));   }++  ReturnTuple Call_abs(const S<TypeInstance>& self, const ParamTuple& params, const ValueTuple& args) final {+    TRACE_FUNCTION("Math.abs")+    const PrimInt Var_arg1 = (args.At(0))->AsInt();+    return ReturnTuple(Box_Int(std::abs(Var_arg1)));+  } };  struct Impl_Value_Math : public Value_Math {

@@ -55,6 +55,7 @@ const TypeFunction& Function_Math_tan = (*new TypeFunction{ 0, 1, 1, "Math", "tan", Functions_Math, 23 }); const TypeFunction& Function_Math_tanh = (*new TypeFunction{ 0, 1, 1, "Math", "tanh", Functions_Math, 24 }); const TypeFunction& Function_Math_trunc = (*new TypeFunction{ 0, 1, 1, "Math", "trunc", Functions_Math, 25 });+const TypeFunction& Function_Math_abs = (*new TypeFunction{ 0, 1, 1, "Math", "abs", Functions_Math, 26 });  std::string Category_Math::CategoryName() const { return "Math"; } @@ -128,9 +129,10 @@     &Type_Math::Call_tan,     &Type_Math::Call_tanh,     &Type_Math::Call_trunc,+    &Type_Math::Call_abs,   };   if (label.collection == Functions_Math) {-    if (label.function_num < 0 || label.function_num >= 26) {+    if (label.function_num < 0 || label.function_num >= sizeof Table_Math / sizeof(CallType)) {       FAIL() << "Bad function call " << label;     }     return (this->*Table_Math[label.function_num])(self, params, args);

@@ -81,6 +81,7 @@   virtual ReturnTuple Call_tan(const S<TypeInstance>& self, const ParamTuple& params, const ValueTuple& args) = 0;   virtual ReturnTuple Call_tanh(const S<TypeInstance>& self, const ParamTuple& params, const ValueTuple& args) = 0;   virtual ReturnTuple Call_trunc(const S<TypeInstance>& self, const ParamTuple& params, const ValueTuple& args) = 0;+  virtual ReturnTuple Call_abs(const S<TypeInstance>& self, const ParamTuple& params, const ValueTuple& args) = 0;    Category_Math& parent; };

@@ -47,4 +47,6 @@    @type isinf (Float) -> (Bool)   @type isnan (Float) -> (Bool)++  @type abs (Int) -> (Int) }

@@ -127,3 +127,9 @@     fail("Failed")   } }++unittest abs {+  \ Testing.checkEquals<?>(Math.abs(-10),10)+  \ Testing.checkEquals<?>(Math.abs(10),10)+  \ Testing.checkEquals<?>(Math.abs(0),0)+}

@@ -86,7 +86,7 @@       &Type_Argv::Call_global,     };     if (label.collection == Functions_Argv) {-      if (label.function_num < 0 || label.function_num >= 1) {+      if (label.function_num < 0 || label.function_num >= sizeof Table_Argv / sizeof(CallType)) {         FAIL() << "Bad function call " << label;       }       return (this->*Table_Argv[label.function_num])(self, params, args);@@ -109,7 +109,7 @@       &Value_Argv::Call_subSequence,     };     if (label.collection == Functions_ReadPosition) {-      if (label.function_num < 0 || label.function_num >= 3) {+      if (label.function_num < 0 || label.function_num >= sizeof Table_ReadPosition / sizeof(CallType)) {         FAIL() << "Bad function call " << label;       }       return (this->*Table_ReadPosition[label.function_num])(self, params, args);

@@ -90,7 +90,7 @@       &Type_SimpleInput::Call_stdin,     };     if (label.collection == Functions_SimpleInput) {-      if (label.function_num < 0 || label.function_num >= 1) {+      if (label.function_num < 0 || label.function_num >= sizeof Table_SimpleInput / sizeof(CallType)) {         FAIL() << "Bad function call " << label;       }       return (this->*Table_SimpleInput[label.function_num])(self, params, args);@@ -112,7 +112,7 @@       &Value_SimpleInput::Call_readBlock,     };     if (label.collection == Functions_BlockReader) {-      if (label.function_num < 0 || label.function_num >= 2) {+      if (label.function_num < 0 || label.function_num >= sizeof Table_BlockReader / sizeof(CallType)) {         FAIL() << "Bad function call " << label;       }       return (this->*Table_BlockReader[label.function_num])(self, params, args);

@@ -100,7 +100,7 @@       &Type_SimpleOutput::Call_stdout,     };     if (label.collection == Functions_SimpleOutput) {-      if (label.function_num < 0 || label.function_num >= 3) {+      if (label.function_num < 0 || label.function_num >= sizeof Table_SimpleOutput / sizeof(CallType)) {         FAIL() << "Bad function call " << label;       }       return (this->*Table_SimpleOutput[label.function_num])(self, params, args);@@ -131,13 +131,13 @@       &Value_SimpleOutput::Call_write,     };     if (label.collection == Functions_BufferedWriter) {-      if (label.function_num < 0 || label.function_num >= 1) {+      if (label.function_num < 0 || label.function_num >= sizeof Table_BufferedWriter / sizeof(CallType)) {         FAIL() << "Bad function call " << label;       }       return (this->*Table_BufferedWriter[label.function_num])(self, params, args);     }     if (label.collection == Functions_Writer) {-      if (label.function_num < 0 || label.function_num >= 1) {+      if (label.function_num < 0 || label.function_num >= sizeof Table_Writer / sizeof(CallType)) {         FAIL() << "Bad function call " << label;       }       return (this->*Table_Writer[label.function_num])(self, params, args);

@@ -52,6 +52,7 @@   csGetTypeFunction,   csGetVariable,   csInheritReturns,+  csInheritUsed,   csIsNamedReturns,   csIsUnreachable,   csPrimNamedReturns,@@ -113,6 +114,7 @@   ccClearOutput :: a -> m a   ccUpdateAssigned :: a -> VariableName -> m a   ccAddUsed :: a -> UsedVariable c -> m a+  ccInheritUsed :: a -> a -> m a   ccInheritReturns :: a -> [a] -> m a   ccRegisterReturn :: a -> [c] -> Maybe ExpressionType -> m a   ccPrimNamedReturns :: a -> m [ReturnVariable]@@ -159,7 +161,7 @@     uvContext :: [c],     uvName :: VariableName   }-  deriving (Show)+  deriving (Eq,Ord,Show)  data CleanupBlock c s =   CleanupBlock {@@ -244,6 +246,9 @@  csAddUsed :: CompilerContext c m s a => UsedVariable c -> CompilerState a m () csAddUsed n = fmap (\x -> ccAddUsed x n) get >>= lift >>= put++csInheritUsed :: CompilerContext c m s a => a -> CompilerState a m ()+csInheritUsed c = fmap (\x -> ccInheritUsed x c) get >>= lift >>= put  csInheritReturns :: CompilerContext c m s a => [a] -> CompilerState a m () csInheritReturns xs = fmap (\x -> ccInheritReturns x xs) get >>= lift >>= put

@@ -398,7 +398,7 @@           pcLoopSetup = pcLoopSetup ctx,           pcCleanupBlocks = pcCleanupBlocks ctx,           pcInCleanup = pcInCleanup ctx,-          pcUsedVars = v:(pcUsedVars ctx),+          pcUsedVars = pcUsedVars ctx ++ [v],           pcExprMap = pcExprMap ctx,           pcReservedMacros = pcReservedMacros ctx,           pcNoTrace = pcNoTrace ctx@@ -444,6 +444,34 @@       combineParallel (ValidateNames ns ts ra1,j1) (ValidateNames _ _ ra2,j2) = (ValidateNames ns ts $ Map.union ra1 ra2,min j1 j2)       combineParallel (r@(ValidatePositions _),j1) (_,j2) = (r,min j1 j2)       combineParallel (_,j1) (r@(ValidatePositions _),j2) = (r,min j1 j2)+  ccInheritUsed ctx ctx2 = return $ ProcedureContext {+      pcScope = pcScope ctx,+      pcType = pcType ctx,+      pcExtParams = pcExtParams ctx,+      pcIntParams = pcIntParams ctx,+      pcMembers = pcMembers ctx,+      pcCategories = pcCategories ctx,+      pcAllFilters = pcAllFilters ctx,+      pcExtFilters = pcExtFilters ctx,+      pcIntFilters = pcIntFilters ctx,+      pcParamScopes = pcParamScopes ctx,+      pcFunctions = pcFunctions ctx,+      pcVariables = pcVariables ctx,+      pcReturns = pcReturns ctx,+      pcJumpType = pcJumpType ctx,+      pcIsNamed = pcIsNamed ctx,+      pcPrimNamed = pcPrimNamed ctx,+      pcRequiredTypes = pcRequiredTypes ctx,+      pcOutput = pcOutput ctx,+      pcDisallowInit = pcDisallowInit ctx,+      pcLoopSetup = pcLoopSetup ctx,+      pcCleanupBlocks = pcCleanupBlocks ctx,+      pcInCleanup = pcInCleanup ctx,+      pcUsedVars = pcUsedVars ctx ++ pcUsedVars ctx2,+      pcExprMap = pcExprMap ctx,+      pcReservedMacros = pcReservedMacros ctx,+      pcNoTrace = pcNoTrace ctx+    }   ccRegisterReturn ctx c vs = do     returns <- check (pcReturns ctx)     return $ ProcedureContext {

@@ -99,7 +99,7 @@     psDefine :: [DefinedCategory c]   } -compileLanguageModule :: (Show c, CollectErrorsM m) =>+compileLanguageModule :: (Ord c, Show c, CollectErrorsM m) =>   LanguageModule c -> [PrivateSource c] -> m [CxxOutput] compileLanguageModule (LanguageModule ns0 ns1 ns2 cs0 ps0 ts0 cs1 ps1 ts1 ex ss em) xa = do   checkSupefluous $ Set.toList $ (Set.fromList ex) `Set.difference` ca@@ -205,7 +205,7 @@     streamlinedError n =       compilerErrorM $ "Category " ++ show n ++ " cannot be streamlined because it was not declared external" -compileTestsModule :: (Show c, CollectErrorsM m) =>+compileTestsModule :: (Ord c, Show c, CollectErrorsM m) =>   LanguageModule c -> Namespace -> [String] -> [AnyCategory c] -> [DefinedCategory c] ->   [TestProcedure c] -> m ([CxxOutput],CxxOutput,[(FunctionName,[c])]) compileTestsModule cm ns args cs ds ts = do@@ -219,7 +219,7 @@   (main,fs) <- compileTestMain cm args xs ts   return (xx,main,fs) -compileTestMain :: (Show c, CollectErrorsM m) =>+compileTestMain :: (Ord c, Show c, CollectErrorsM m) =>   LanguageModule c -> [String] -> PrivateSource c -> [TestProcedure c] ->   m (CxxOutput,[(FunctionName,[c])]) compileTestMain (LanguageModule ns0 ns1 ns2 cs0 ps0 ts0 cs1 ps1 ts1 _ _ em) args ts2 tests = do@@ -230,7 +230,7 @@   return (output,tests') where   tm = foldM includeNewTypes defaultCategories [cs0,cs1,ps0,ps1,ts0,ts1,psCategory ts2] -compileModuleMain :: (Show c, CollectErrorsM m) =>+compileModuleMain :: (Ord c, Show c, CollectErrorsM m) =>   LanguageModule c -> [PrivateSource c] -> CategoryName -> FunctionName -> m CxxOutput compileModuleMain (LanguageModule ns0 ns1 ns2 cs0 ps0 _ cs1 ps1 _ _ _ em) xa n f = do   let resolved = filter (\d -> dcName d == n) $ concat $ map psDefine $ filter (not . psTesting) xa@@ -247,7 +247,7 @@       "Multiple matches for main category " ++ show n !!>         mapErrorsM_ (\d -> compilerErrorM $ "Defined at " ++ formatFullContext (dcContext d)) ds -compileCategoryDeclaration :: (Show c, CollectErrorsM m) =>+compileCategoryDeclaration :: (Ord c, Show c, CollectErrorsM m) =>   Bool -> CategoryMap c -> Set.Set Namespace -> AnyCategory c -> m CxxOutput compileCategoryDeclaration testing _ ns t =   return $ CxxOutput (Just $ getCategoryName t)@@ -300,7 +300,7 @@       let allInit = intercalate ", " $ initParent:initPassed       return $ onlyCode $ typeName (getCategoryName t) ++ "(" ++ allArgs ++ ") : " ++ allInit ++ " {}" -compileConcreteTemplate :: (Show c, CollectErrorsM m) =>+compileConcreteTemplate :: (Ord c, Show c, CollectErrorsM m) =>   Bool -> CategoryMap c -> CategoryName -> m CxxOutput compileConcreteTemplate testing ta n = do   (_,t) <- getConcreteCategory ta ([],n)@@ -332,7 +332,7 @@       ]     funcName f = show (sfType f) ++ "." ++ show (sfName f) -compileConcreteStreamlined :: (Show c, CollectErrorsM m) =>+compileConcreteStreamlined :: (Ord c, Show c, CollectErrorsM m) =>   Bool -> CategoryMap c -> CategoryName -> m [CxxOutput] compileConcreteStreamlined testing ta n =  "In streamlined compilation of " ++ show n ??> do   (_,t) <- getConcreteCategory ta ([],n)@@ -354,7 +354,7 @@                       []   return [hxx,cxx] -compileConcreteDefinition :: (Show c, CollectErrorsM m) =>+compileConcreteDefinition :: (Ord c, Show c, CollectErrorsM m) =>   Bool -> CategoryMap c -> ExprMap c -> Set.Set Namespace -> Maybe [ValueRefine c] ->   DefinedCategory c -> m CxxOutput compileConcreteDefinition testing ta em ns rs dd@(DefinedCategory c n pi _ _ fi ms _ fs) = do@@ -413,7 +413,7 @@     ] ++ map (return . snd) (cf ++ tf ++ vf)   commonDefineAll testing t ns rs top bottom ce te fe   where-    disallowTypeMembers :: (Show c, CollectErrorsM m) =>+    disallowTypeMembers :: (Ord c, Show c, CollectErrorsM m) =>       [DefinedMember c] -> m ()     disallowTypeMembers tm =       collectAllM_ $ flip map tm@@ -622,9 +622,9 @@     ["  static const CallType " ++ tableName n2 ++ "[] = {"] ++     map (\f -> "    &" ++ name f ++ ",") (Set.toList $ Set.fromList $ map sfName fs2) ++     ["  };"]-  dispatch (n2,fs2) = [+  dispatch (n2,_) = [       "  if (label.collection == " ++ collectionName n2 ++ ") {",-      "    if (label.function_num < 0 || label.function_num >= " ++ show (length fs2) ++ ") {",+      "    if (label.function_num < 0 || label.function_num >= sizeof " ++ tableName n2 ++ " / sizeof(CallType)) {",       "      FAIL() << \"Bad function call \" << label;",       "    }",       "    return (this->*" ++ tableName n2 ++ "[label.function_num])(" ++ args ++ ");",@@ -831,7 +831,7 @@       depIncludes req2 = map (\i -> "#include \"" ++ headerFilename i ++ "\"") $                            Set.toList req2 -createMainFile :: (Show c, CollectErrorsM m) =>+createMainFile :: (Ord c, Show c, CollectErrorsM m) =>   CategoryMap c -> ExprMap c -> CategoryName -> FunctionName -> m (Namespace,[String]) createMainFile tm em n f = "In the creation of the main binary procedure" ??> do   ca <- compileMainProcedure tm em expr@@ -843,7 +843,7 @@     expr = Expression [] (TypeCall [] mainType funcCall) []     argv = onlyCode "ProgramArgv program_argv(argc, argv);" -createTestFile :: (Show c, CollectErrorsM m) =>+createTestFile :: (Ord c, Show c, CollectErrorsM m) =>   CategoryMap c -> ExprMap c  -> [String] -> [TestProcedure c] -> m (CompiledData [String]) createTestFile tm em args ts = "In the creation of the test binary procedure" ??> do   ts' <- fmap mconcat $ mapErrorsM (compileTestProcedure tm em) ts

@@ -37,7 +37,7 @@ import Control.Monad (when) import Control.Monad.Trans.State (execStateT,get,put,runStateT) import Control.Monad.Trans (lift)-import Data.List (intercalate)+import Data.List (intercalate,nub) import qualified Data.Map as Map import qualified Data.Set as Set @@ -61,7 +61,7 @@ import Types.Variance  -compileExecutableProcedure :: (Show c, CollectErrorsM m) =>+compileExecutableProcedure :: (Ord c, Show c, CollectErrorsM m) =>   ScopeContext c -> ScopedFunction c -> ExecutableProcedure c ->   m (CompiledData [String],CompiledData [String]) compileExecutableProcedure ctx ff@(ScopedFunction _ _ _ s as1 rs1 ps1 _ _)@@ -143,16 +143,15 @@         variableProxyType t2 ++ " " ++ variableName (ovName n2) ++         " = " ++ writeStoredVariable t2 (UnwrappedSingle $ "returns.At(" ++ show i ++ ")") ++ ";" -compileCondition :: (Show c, CollectErrorsM m,+compileCondition :: (Ord c, Show c, CollectErrorsM m,                      CompilerContext c m [String] a) =>-  a -> [c] -> Expression c -> CompilerState a m String+  a -> [c] -> Expression c -> CompilerState a m (String,a) compileCondition ctx c e = do   (e',ctx') <- resetBackgroundM $ lift $ runStateT compile ctx-  lift (ccGetRequired ctx') >>= csAddRequired   noTrace <- csGetNoTrace   if noTrace-     then return e'-     else return $ predTraceContext c ++ e'+     then return (e',ctx')+     else return (predTraceContext c ++ e',ctx')   where     compile = "In condition at " ++ formatFullContext c ??> do       (ts,e') <- compileExpression e@@ -161,11 +160,11 @@       where         checkCondition (Positional [t]) | t == boolRequiredValue = return ()         checkCondition (Positional ts) =-          compilerErrorM $ "Conditionals must have exactly one Bool return but found {" ++-                           intercalate "," (map show ts) ++ "}"+          compilerErrorM $ "Expected exactly one Bool value but got " +++                           intercalate ", " (map show ts)  -- Returns the state so that returns can be properly checked for if/elif/else.-compileProcedure :: (Show c, CollectErrorsM m,+compileProcedure :: (Ord c, Show c, CollectErrorsM m,                      CompilerContext c m [String] a) =>   a -> Procedure c -> CompilerState a m a compileProcedure ctx (Procedure _ ss) = do@@ -181,14 +180,14 @@            s' <- resetBackgroundM $ compileStatement s            return s' -maybeSetTrace :: (Show c, CollectErrorsM m,+maybeSetTrace :: (Ord c, Show c, CollectErrorsM m,                   CompilerContext c m [String] a) =>   [c] -> CompilerState a m () maybeSetTrace c = do   noTrace <- csGetNoTrace   when (not noTrace) $ csWrite $ setTraceContext c -compileStatement :: (Show c, CollectErrorsM m,+compileStatement :: (Ord c, Show c, CollectErrorsM m,                      CompilerContext c m [String] a) =>   Statement c -> CompilerState a m () compileStatement (EmptyReturn c) = do@@ -306,7 +305,7 @@ compileStatement (NoValueExpression _ v) = compileVoidExpression v compileStatement (RawCodeLine s) = csWrite [s] -compileRegularInit :: (Show c, CollectErrorsM m,+compileRegularInit :: (Ord c, Show c, CollectErrorsM m,                        CompilerContext c m [String] a) =>   DefinedMember c -> CompilerState a m () compileRegularInit (DefinedMember _ _ _ _ Nothing) = return ()@@ -315,7 +314,7 @@   let assign = Assignment c2 (Positional [ExistingVariable (InputValue c2 n2)]) e   compileStatement assign -compileLazyInit :: (Show c, CollectErrorsM m,+compileLazyInit :: (Ord c, Show c, CollectErrorsM m,                    CompilerContext c m [String] a) =>   DefinedMember c -> CompilerState a m () compileLazyInit (DefinedMember _ _ _ _ Nothing) = return ()@@ -330,7 +329,7 @@     "In initialization of " ++ show n ++ " at " ++ formatFullContext c   csWrite [variableName n ++ "([this]() { return " ++ writeStoredVariable t1 e' ++ "; })"] -compileVoidExpression :: (Show c, CollectErrorsM m,+compileVoidExpression :: (Ord c, Show c, CollectErrorsM m,                          CompilerContext c m [String] a) =>   VoidExpression c -> CompilerState a m () compileVoidExpression (Conditional ie) = compileIfElifElse ie@@ -344,64 +343,58 @@   autoInlineOutput ctx   csWrite ["}"] -compileIfElifElse :: (Show c, CollectErrorsM m,+compileIfElifElse :: (Ord c, Show c, CollectErrorsM m,                       CompilerContext c m [String] a) =>   IfElifElse c -> CompilerState a m () compileIfElifElse (IfStatement c e p es) = do   ctx0 <- getCleanContext-  e' <- compileCondition ctx0 c e-  ctx <- compileProcedure ctx0 p-  (lift $ ccGetRequired ctx) >>= csAddRequired-  csWrite ["if (" ++ e' ++ ") {"]-  getAndIndentOutput ctx >>= csWrite-  csWrite ["}"]-  cs <- unwind es-  csInheritReturns (ctx:cs)+  cs <- commonIf ctx0 "if" c e p es+  csInheritReturns cs   where-    unwind (IfStatement c2 e2 p2 es2) = do-      ctx0 <- getCleanContext-      e2' <- compileCondition ctx0 c2 e2-      ctx <- compileProcedure ctx0 p2-      (lift $ ccGetRequired ctx) >>= csAddRequired-      csWrite ["else if (" ++ e2' ++ ") {"]-      getAndIndentOutput ctx >>= csWrite-      csWrite ["}"]-      cs <- unwind es2-      return $ ctx:cs-    unwind (ElseStatement _ p2) = do-      ctx0 <- getCleanContext+    unwind ctx0 (IfStatement c2 e2 p2 es2) = commonIf ctx0 "else if" c2 e2 p2 es2+    unwind ctx0 (ElseStatement _ p2) = do       ctx <- compileProcedure ctx0 p2-      (lift $ ccGetRequired ctx) >>= csAddRequired+      inheritRequired ctx       csWrite ["else {"]       getAndIndentOutput ctx >>= csWrite       csWrite ["}"]       return [ctx]-    unwind TerminateConditional = fmap (:[]) get+    unwind ctx0 TerminateConditional = return [ctx0]+    commonIf ctx0 s c2 e2 p2 es2 = do+      (e2',ctx1) <- compileCondition ctx0 c2 e2+      ctx <- compileProcedure ctx1 p2+      inheritRequired ctx+      csWrite [s ++ " (" ++ e2' ++ ") {"]+      getAndIndentOutput ctx >>= csWrite+      csWrite ["}"]+      cs <- unwind ctx1 es2+      return $ ctx:cs compileIfElifElse _ = undefined -compileWhileLoop :: (Show c, CollectErrorsM m,+compileWhileLoop :: (Ord c, Show c, CollectErrorsM m,                      CompilerContext c m [String] a) =>   WhileLoop c -> CompilerState a m () compileWhileLoop (WhileLoop c e p u) = do   ctx0 <- getCleanContext-  e' <- compileCondition ctx0 c e+  (e',ctx1) <- compileCondition ctx0 c e+  csInheritReturns [ctx1]   ctx0' <- case u of                 Just p2 -> do-                  ctx1 <- lift $ ccStartLoop ctx0 (LoopSetup [])-                  ctx2 <- compileProcedure ctx1 p2-                  (lift $ ccGetRequired ctx2) >>= csAddRequired-                  p2' <- getAndIndentOutput ctx2-                  lift $ ccStartLoop ctx0 (LoopSetup p2')-                _ -> lift $ ccStartLoop ctx0 (LoopSetup [])+                  ctx2 <- lift $ ccStartLoop ctx1 (LoopSetup [])+                  ctx3 <- compileProcedure ctx2 p2+                  inheritRequired ctx3+                  p2' <- getAndIndentOutput ctx3+                  lift $ ccStartLoop ctx1 (LoopSetup p2')+                _ -> lift $ ccStartLoop ctx1 (LoopSetup [])   (LoopSetup u') <- lift $ ccGetLoop ctx0'   ctx <- compileProcedure ctx0' p-  (lift $ ccGetRequired ctx) >>= csAddRequired+  inheritRequired ctx   csWrite ["while (" ++ e' ++ ") {"]   getAndIndentOutput ctx >>= csWrite   csWrite $ ["{"] ++ u' ++ ["}"]   csWrite ["}"] -compileScopedBlock :: (Show c, CollectErrorsM m,+compileScopedBlock :: (Ord c, Show c, CollectErrorsM m,                        CompilerContext c m [String] a) =>   ScopedBlock c -> CompilerState a m () compileScopedBlock s@(ScopedBlock _ _ _ c2 _) = do@@ -466,7 +459,7 @@     rewriteScoped (ScopedBlock _ p cl _ s2) =       ([],p,cl,s2) -compileExpression :: (Show c, CollectErrorsM m,+compileExpression :: (Ord c, Show c, CollectErrorsM m,                       CompilerContext c m [String] a) =>   Expression c -> CompilerState a m (ExpressionType,ExprValue) compileExpression = compile where@@ -511,11 +504,11 @@     compile (Expression c (ParensExpression c2 e0) [ValueCall c (FunctionCall c fn ps (Positional [e]))])   compile (UnaryExpression c (FunctionOperator _ (FunctionSpec c2 UnqualifiedFunction fn ps)) e) =     compile (Expression c (UnqualifiedCall c2 (FunctionCall c fn ps (Positional [e]))) [])-  compile (UnaryExpression c (NamedOperator "-") (Literal (IntegerLiteral _ _ l))) =+  compile (UnaryExpression _ (NamedOperator c "-") (Literal (IntegerLiteral _ _ l))) =     compile (Literal (IntegerLiteral c False (-l)))-  compile (UnaryExpression c (NamedOperator "-") (Literal (DecimalLiteral _ l e))) =+  compile (UnaryExpression _ (NamedOperator c "-") (Literal (DecimalLiteral _ l e))) =     compile (Literal (DecimalLiteral c (-l) e))-  compile (UnaryExpression c (NamedOperator o) e) = do+  compile (UnaryExpression _ (NamedOperator c o) e) = do     (Positional ts,e') <- compileExpression e     t' <- requireSingle c ts     doUnary t' e'@@ -577,7 +570,7 @@     compile (Expression c (ParensExpression c2 e0) [ValueCall c (FunctionCall c fn ps (Positional [e1,e2]))])   compile (InfixExpression c e1 (FunctionOperator _ (FunctionSpec c2 UnqualifiedFunction fn ps)) e2) =     compile (Expression c (UnqualifiedCall c2 (FunctionCall c fn ps (Positional [e1,e2]))) [])-  compile (InfixExpression c e1 (NamedOperator o) e2) = do+  compile (InfixExpression _ e1 (NamedOperator c o) e2) = do     e1' <- compileExpression e1     e2' <- if o `Set.member` logical               then isolateExpression e2 -- Ignore named-return assignments.@@ -586,7 +579,8 @@   isolateExpression e = do     ctx <- getCleanContext     (e',ctx') <- lift $ runStateT (compileExpression e) ctx-    (lift $ ccGetRequired ctx') >>= csAddRequired+    inheritRequired ctx'+    csInheritUsed ctx'     return e'   arithmetic1 = Set.fromList ["*","/"]   arithmetic2 = Set.fromList ["%"]@@ -604,7 +598,7 @@       bind t1 t2         | t1 /= t2 =           compilerErrorM $ "Cannot " ++ show o ++ " " ++ show t1 ++ " and " ++-                                 show t2 ++ formatFullContextBrace c+                           show t2 ++ formatFullContextBrace c         | o `Set.member` comparison && t1 == intRequiredValue = do           return (Positional [boolRequiredValue],glueInfix PrimInt PrimBool e1 o e2)         | o `Set.member` comparison && t1 == floatRequiredValue = do@@ -658,7 +652,7 @@     compilerErrorM $ "Function call requires 1 return but found but found {" ++                             intercalate "," (map show ts) ++ "}" ++ formatFullContextBrace c2 -lookupValueFunction :: (Show c, CollectErrorsM m,+lookupValueFunction :: (Ord c, Show c, CollectErrorsM m,                         CompilerContext c m [String] a) =>   ValueType -> FunctionCall c -> CompilerState a m (ScopedFunction c) lookupValueFunction (ValueType WeakValue t) (FunctionCall c _ _ _) =@@ -670,7 +664,7 @@ lookupValueFunction (ValueType RequiredValue t) (FunctionCall c n _ _) =   csGetTypeFunction c (Just t) n -compileExpressionStart :: (Show c, CollectErrorsM m,+compileExpressionStart :: (Ord c, Show c, CollectErrorsM m,                            CompilerContext c m [String] a) =>   ExpressionStart c -> CompilerState a m (ExpressionType,ExprValue) compileExpressionStart (NamedVariable (OutputValue c n)) = do@@ -813,13 +807,13 @@   return (Positional [t0],readStoredVariable lazy t0 $ "(" ++ scoped ++ variableName n ++                                                      " = " ++ writeStoredVariable t0 e' ++ ")") -disallowInferred :: (Show c, CollectErrorsM m) => Positional (InstanceOrInferred c) -> m [GeneralInstance]+disallowInferred :: (Ord c, Show c, CollectErrorsM m) => Positional (InstanceOrInferred c) -> m [GeneralInstance] disallowInferred = mapErrorsM disallow . pValues where   disallow (AssignedInstance _ t) = return t   disallow (InferredInstance c) =     compilerErrorM $ "Type inference is not allowed in reduce calls" ++ formatFullContextBrace c -compileFunctionCall :: (Show c, CollectErrorsM m,+compileFunctionCall :: (Ord c, Show c, CollectErrorsM m,                         CompilerContext c m [String] a) =>   Maybe String -> ScopedFunction c -> FunctionCall c ->   CompilerState a m (ExpressionType,ExprValue)@@ -876,7 +870,7 @@     checkArg r fa t0 (i,t1) = do       checkValueAssignment r fa t1 t0 <?? "In argument " ++ show i ++ " to " ++ show (sfName f) -guessParamsFromArgs :: (Show c, CollectErrorsM m, TypeResolver r) =>+guessParamsFromArgs :: (Ord c, Show c, CollectErrorsM m, TypeResolver r) =>   r -> ParamFilters -> ScopedFunction c -> Positional (InstanceOrInferred c) ->   Positional ValueType -> m (Positional GeneralInstance) guessParamsFromArgs r fa f ps ts = do@@ -895,7 +889,7 @@     toInstance p1 (AssignedInstance _ t) = return (p1,t)     toInstance p1 (InferredInstance _)   = return (p1,singleType $ JustInferredType p1) -compileMainProcedure :: (Show c, CollectErrorsM m) =>+compileMainProcedure :: (Ord c, Show c, CollectErrorsM m) =>   CategoryMap c -> ExprMap c -> Expression c -> m (CompiledData [String]) compileMainProcedure tm em e = do   ctx <- getMainContext tm em@@ -905,7 +899,7 @@       ctx0 <- getCleanContext       compileProcedure ctx0 procedure >>= put -compileTestProcedure :: (Show c, CollectErrorsM m) =>+compileTestProcedure :: (Ord c, Show c, CollectErrorsM m) =>   CategoryMap c -> ExprMap c -> TestProcedure c -> m (CompiledData [String]) compileTestProcedure tm em (TestProcedure c n p) = do   ctx <- getMainContext tm em@@ -1009,7 +1003,7 @@     ps' <- sequence ps     return $ "(L_get<S<const " ++ typeBase ++ ">>(" ++ intercalate "," ps' ++ "))" -doImplicitReturn :: (CollectErrorsM m, Show c, CompilerContext c m [String] a) =>+doImplicitReturn :: (CollectErrorsM m, Ord c, Show c, CompilerContext c m [String] a) =>   [c] -> CompilerState a m () doImplicitReturn c = do   named <- csIsNamedReturns@@ -1021,26 +1015,24 @@   if not named      then csWrite ["return ReturnTuple(0);"]      else do-       vars <- csPrimNamedReturns-       sequence_ $ map (csWrite . (:[]) . assign) vars+       getPrimNamedReturns        csWrite ["return returns;"]   where-    assign (ReturnVariable i n t) =-      "returns.At(" ++ show i ++ ") = " ++ useAsUnwrapped (readStoredVariable False t $ variableName n) ++ ";"  autoPositionalCleanup :: (CollectErrorsM m, CompilerContext c m [String] a) =>   [c] -> ExprValue -> CompilerState a m () autoPositionalCleanup c e = do+  named <- csIsNamedReturns   (CleanupBlock ss _ _ req) <- csGetCleanup JumpReturn   csAddRequired req   csSetJumpType c JumpReturn   if null ss      then csWrite ["return " ++ useAsReturns e ++ ";"]      else do-       named <- csIsNamedReturns        if named           then do             csWrite ["returns = " ++ useAsReturns e ++ ";"]+            setPrimNamedReturns             csWrite ss             csWrite ["return returns;"]           else do@@ -1048,11 +1040,29 @@             csWrite ss             csWrite ["return returns;","}"] -autoInsertCleanup :: (Show c, CollectErrorsM m, CompilerContext c m [String] a) =>+setPrimNamedReturns ::  (CollectErrorsM m, CompilerContext c m [String] a) =>+  CompilerState a m ()+setPrimNamedReturns = do+  vars <- csPrimNamedReturns+  sequence_ $ map (csWrite . (:[]) . assign) vars where+    assign (ReturnVariable i n t) =+      variableName n ++ " = " ++ writeStoredVariable t (position i) ++ ";"+    position i = WrappedSingle $ "returns.At(" ++ show i ++ ")"++getPrimNamedReturns ::  (CollectErrorsM m, CompilerContext c m [String] a) =>+  CompilerState a m ()+getPrimNamedReturns = do+  vars <- csPrimNamedReturns+  sequence_ $ map (csWrite . (:[]) . assign) vars where+    assign (ReturnVariable i n t) =+      "returns.At(" ++ show i ++ ") = " ++ useAsUnwrapped (readStoredVariable False t $ variableName n) ++ ";"++autoInsertCleanup :: (Ord c, Show c, CollectErrorsM m, CompilerContext c m [String] a) =>   [c] -> JumpType -> a -> CompilerState a m () autoInsertCleanup c j ctx = do   (CleanupBlock ss vs jump req) <- lift $ ccGetCleanup ctx j-  lift (ccCheckVariableInit ctx vs) <?? "In inlining of cleanup block after statement at " ++ formatFullContext c+  lift (ccCheckVariableInit ctx $ nub vs) <??+    "In inlining of cleanup block after statement at " ++ formatFullContext c   let vs2 = map (\(UsedVariable c0 v) -> UsedVariable (c ++ c0) v) vs   -- This is needed in case a cleanup is inlined within another cleanup, e.g.,   -- e.g., if the latter has a break statement.@@ -1061,14 +1071,18 @@   csAddRequired req   csSetJumpType c jump -autoInlineOutput :: (Show c, CollectErrorsM m, CompilerContext c m [String] a) =>+inheritRequired :: (CollectErrorsM m, CompilerContext c m [String] a) =>   a -> CompilerState a m ()+inheritRequired ctx = lift (ccGetRequired ctx) >>= csAddRequired++autoInlineOutput :: (Ord c, Show c, CollectErrorsM m, CompilerContext c m [String] a) =>+  a -> CompilerState a m () autoInlineOutput ctx = do-  (lift $ ccGetRequired ctx) >>= csAddRequired+  inheritRequired ctx   getAndIndentOutput ctx >>= csWrite   csInheritReturns [ctx] -getAndIndentOutput :: (Show c, CollectErrorsM m, CompilerContext c m [String] a) =>+getAndIndentOutput :: (Ord c, Show c, CollectErrorsM m, CompilerContext c m [String] a) =>   a -> CompilerState a m [String] getAndIndentOutput ctx = fmap indentCode (lift $ ccGetOutput ctx) 

@@ -21,7 +21,6 @@ module Parser.DefinedCategory ( ) where -import Control.Monad (when) import Prelude hiding (pi)  import Base.CompilerError@@ -98,10 +97,9 @@   return (ms,ps2,fs2) where     singleFunction = labeled "function" $ do       f <- parseScopedFunction parseScope (return n)+      lookAhead (sepAfter $ string_ $ show (sfName f)) <|>+        (compilerErrorM $ "expected definition of function " ++ show (sfName f))       p <- labeled ("definition of function " ++ show (sfName f)) $ sourceParser-      when (sfName f /= epName p) $-        compilerErrorM $ "expecting definition of function " ++ show (sfName f) ++-                         " but got definition of " ++ show (epName p)       return (f,p)     catchUnscopedType = labeled "" $ do       _ <- try sourceParser :: TextParser ValueType

@@ -22,6 +22,7 @@ module Parser.Procedure ( ) where +import Control.Monad (when) import qualified Data.Set as Set  import Base.CompilerError@@ -251,10 +252,13 @@       p <- between (sepAfter $ string_ "{") (sepAfter $ string_ "}") sourceParser       return $ NoValueExpression [c] (Unconditional p) -unaryOperator :: TextParser (Operator c)-unaryOperator = op >>= return . NamedOperator where-  op = labeled "unary operator" $ foldr (<|>) empty $ map (try . operator) ops-  ops = logicalUnary ++ arithUnary ++ bitwiseUnary+unaryOperator :: TextParser (Operator SourceContext)+unaryOperator = do+  c <- getSourceContext+  o <- op+  return $ NamedOperator [c] o where+    op = labeled "unary operator" $ foldr (<|>) empty $ map (try . operator) ops+    ops = logicalUnary ++ arithUnary ++ bitwiseUnary  logicalUnary :: [String] logicalUnary = ["!"]@@ -265,10 +269,13 @@ bitwiseUnary :: [String] bitwiseUnary = ["~"] -infixOperator :: TextParser (Operator c)-infixOperator = op >>= return . NamedOperator where-  op = labeled "binary operator" $ foldr (<|>) empty $ map (try . operator) ops-  ops = compareInfix ++ logicalInfix ++ addInfix ++ subInfix ++ multInfix ++ bitwiseInfix ++ bitshiftInfix+infixOperator :: TextParser (Operator SourceContext)+infixOperator =  do+  c <- getSourceContext+  o <- op+  return $ NamedOperator [c] o where+    op = labeled "binary operator" $ foldr (<|>) empty $ map (try . operator) ops+    ops = compareInfix ++ logicalInfix ++ addInfix ++ subInfix ++ multInfix ++ divInfix ++ bitwiseInfix ++ bitshiftInfix  compareInfix :: [String] compareInfix = ["==","!=","<","<=",">",">="]@@ -283,24 +290,26 @@ subInfix = ["-"]  multInfix :: [String]-multInfix = ["*","/","%"]+multInfix = ["*"] +divInfix :: [String]+divInfix = ["/","%"]+ bitwiseInfix :: [String] bitwiseInfix = ["&","|","^"]  bitshiftInfix :: [String] bitshiftInfix = [">>","<<"] -infixBefore :: Operator c -> Operator c -> Bool-infixBefore o1 o2 = (infixOrder o1 :: Int) <= (infixOrder o2 :: Int) where-  infixOrder (NamedOperator o)-    -- TODO: Don't hard-code this.-    | o `Set.member` Set.fromList (multInfix ++ bitshiftInfix) = 1-    | o `Set.member` Set.fromList (addInfix ++ subInfix ++ bitwiseInfix) = 2-    | o `Set.member` Set.fromList compareInfix = 4-    | o `Set.member` Set.fromList logicalInfix = 5-  infixOrder _ = 3+leftAssocInfix :: [String]+leftAssocInfix = addInfix ++ subInfix ++ multInfix ++ divInfix ++ bitwiseInfix ++ bitshiftInfix +rightAssocInfix :: [String]+rightAssocInfix = logicalInfix++nonAssocInfix :: [String]+nonAssocInfix = compareInfix+ functionOperator :: TextParser (Operator SourceContext) functionOperator = do   c <- getSourceContext@@ -309,6 +318,48 @@   infixFuncEnd   return $ FunctionOperator [c] q +inOperatorSet :: Operator c -> [String] -> Bool+inOperatorSet (NamedOperator _ o) ss = o `Set.member` Set.fromList ss+inOperatorSet _                   _  = False++bothInOperatorSet :: Operator c -> Operator c -> [String] -> Bool+bothInOperatorSet o1 o2 ss = o1 `inOperatorSet` ss && o2 `inOperatorSet` ss++infixPrecedence :: Operator c -> Int+infixPrecedence o+  -- TODO: Don't hard-code this.+  | o `inOperatorSet` (multInfix ++ divInfix ++ bitshiftInfix) = 1+  | o `inOperatorSet` (addInfix ++ subInfix ++ bitwiseInfix) = 2+  | o `inOperatorSet` compareInfix = 4+  | o `inOperatorSet` logicalInfix = 5+infixPrecedence _ = 3++infixBefore :: (Show c, ErrorContextM m) => Operator c -> Operator c -> m Bool+infixBefore o1 o2 = do+  let prec1 = infixPrecedence o1+  let prec2 = infixPrecedence o2+  if prec1 /= prec2+     then return $ prec1 < prec2+     -- NOTE: Ambiguity is checked separately so that the error occurs where the+     -- second operator is parsed, rather than at the end of the expression.+     else if bothInOperatorSet o1 o2 rightAssocInfix+             then return False  -- Logical operators are right-associative.+             else return True   -- Default is left-associative.+  where++checkAmbiguous :: (Show c, ErrorContextM m) => Operator c -> Operator c -> m ()+checkAmbiguous o1 o2 = checked where+  formatOperator o = show (getOperatorName o) +++                     " (" ++ formatFullContext (getOperatorContext o) ++ ")"+  checked+    | infixPrecedence o1 /= infixPrecedence o2 = return ()+    | bothInOperatorSet o1 o2 leftAssocInfix  = return ()+    | bothInOperatorSet o1 o2 rightAssocInfix = return ()+    | isFunctionOperator o1 && isFunctionOperator o2 = return ()+    | otherwise =+        compilerErrorM $ "the order of operators " ++ formatOperator o1 +++                         " and " ++ formatOperator o2 ++ " is ambiguous"+ instance ParseFromSource (Expression SourceContext) where   sourceParser = do     e <- notInfix@@ -318,18 +369,21 @@       asInfix es os = do         c <- getSourceContext         o <- infixOperator <|> functionOperator+        when (not $ null os) $ checkAmbiguous (snd $ last os) o         e2 <- notInfix         let es' = es ++ [e2]         let os' = os ++ [([c],o)]-        asInfix es' os' <|> return (infixToTree [] es' os')-      infixToTree [(e1,c1,o1)] [e2] [] = InfixExpression c1 e1 o1 e2+        asInfix es' os' <|> (infixToTree [] es' os')+      infixToTree [(e1,c1,o1)] [e2] [] = return $ InfixExpression c1 e1 o1 e2       infixToTree [] (e1:es) ((c1,o1):os) = infixToTree [(e1,c1,o1)] es os       infixToTree ((e1,c1,o1):ss) [e2] [] = let e2' = InfixExpression c1 e1 o1 e2 in                                                 infixToTree ss [e2'] []-      infixToTree ((e1,c1,o1):ss) (e2:es) ((c2,o2):os)-        | o1 `infixBefore` o2 = let e1' = InfixExpression c1 e1 o1 e2 in-                                    infixToTree ss (e1':es) ((c2,o2):os)-        | otherwise = infixToTree ((e2,c2,o2):(e1,c1,o1):ss) es os+      infixToTree ((e1,c1,o1):ss) (e2:es) ((c2,o2):os) = do+        before <- o1 `infixBefore` o2+        if before+           then let e1' = InfixExpression c1 e1 o1 e2 in+                          infixToTree ss (e1':es) ((c2,o2):os)+           else infixToTree ((e2,c2,o2):(e1,c1,o1):ss) es os       infixToTree _ _ _ = undefined       literal = do         l <- sourceParser

@@ -208,6 +208,13 @@     checkShortParseFail "x <- 'xx'",     checkShortParseSuccess "x <- \"'xx\"", +    checkShortParseFail "_ <- 1 < 2 < 3",+    checkShortParseSuccess "_ <- 1 << 2 >> 3",+    checkShortParseSuccess "_ <- 1 - 2 - 3",+    checkShortParseSuccess "_ <- 1 - 2 / 3",+    checkShortParseSuccess "_ <- 1 / 2 - 3",+    checkShortParseSuccess "_ <- x < y || z > w",+     checkParsesAs "'\"'"                   (\e -> case e of                               (Literal (CharLiteral _ '"')) -> True@@ -218,18 +225,18 @@                               (InfixExpression _                                 (InfixExpression _                                   (InfixExpression _-                                    (InfixExpression _-                                      (Literal (IntegerLiteral _ False 1)) (NamedOperator "+")-                                      (Literal (IntegerLiteral _ False 2))) (NamedOperator "<")-                                    (Literal (IntegerLiteral _ False 4))) (NamedOperator "&&")+                                    (Literal (IntegerLiteral _ False 1)) (NamedOperator _ "+")+                                    (Literal (IntegerLiteral _ False 2))) (NamedOperator _ "<")+                                  (Literal (IntegerLiteral _ False 4))) (NamedOperator _ "&&")+                                (InfixExpression _                                   (InfixExpression _-                                    (Literal (IntegerLiteral _ False 3)) (NamedOperator ">=")+                                    (Literal (IntegerLiteral _ False 3)) (NamedOperator _ ">=")                                     (InfixExpression _                                       (InfixExpression _-                                        (Literal (IntegerLiteral _ False 1)) (NamedOperator "*")-                                        (Literal (IntegerLiteral _ False 2))) (NamedOperator "+")-                                      (Literal (IntegerLiteral _ False 1))))) (NamedOperator "||")-                                (Literal (BoolLiteral _ True))) -> True+                                        (Literal (IntegerLiteral _ False 1)) (NamedOperator _ "*")+                                        (Literal (IntegerLiteral _ False 2))) (NamedOperator _ "+")+                                      (Literal (IntegerLiteral _ False 1)))) (NamedOperator _ "||")+                                  (Literal (BoolLiteral _ True)))) -> True                               _ -> False),      -- This expression isn't really valid, but it ensures that the first ! is@@ -238,11 +245,11 @@                   (\e -> case e of                               (InfixExpression _                                 (InfixExpression _-                                  (UnaryExpression _ (NamedOperator "!")-                                    (Expression _ (NamedVariable (OutputValue _ (VariableName "x"))) [])) (NamedOperator "*")-                                  (UnaryExpression _ (NamedOperator "!")-                                    (Expression _ (NamedVariable (OutputValue _ (VariableName "y"))) []))) (NamedOperator "+")-                                (UnaryExpression _ (NamedOperator "!")+                                  (UnaryExpression _ (NamedOperator _ "!")+                                    (Expression _ (NamedVariable (OutputValue _ (VariableName "x"))) [])) (NamedOperator _ "*")+                                  (UnaryExpression _ (NamedOperator _ "!")+                                    (Expression _ (NamedVariable (OutputValue _ (VariableName "y"))) []))) (NamedOperator _ "+")+                                (UnaryExpression _ (NamedOperator _ "!")                                   (Expression _ (NamedVariable (OutputValue _ (VariableName "z"))) []))) -> True                               _ -> False), 

@@ -44,8 +44,11 @@   WhileLoop(..),   assignableName,   getExpressionContext,+  getOperatorContext,+  getOperatorName,   getStatementContext,   isDiscardedInput,+  isFunctionOperator,   isLiteralCategory,   isRawCodeLine,   isUnnamedReturns,@@ -238,9 +241,21 @@   deriving (Show)  data Operator c =-  NamedOperator String |+  NamedOperator [c] String |   FunctionOperator [c] (FunctionSpec c)   deriving (Show)++getOperatorContext :: Operator c -> [c]+getOperatorContext (NamedOperator c _)    = c+getOperatorContext (FunctionOperator c _) = c++isFunctionOperator :: Operator c -> Bool+isFunctionOperator (FunctionOperator _ _) = True+isFunctionOperator _                      = False++getOperatorName :: Operator c -> FunctionName+getOperatorName (NamedOperator _ n)                         = FunctionName n+getOperatorName (FunctionOperator _ (FunctionSpec _ _ n _)) = n  getExpressionContext :: Expression c -> [c] getExpressionContext (Expression c _ _)        = c

@@ -279,8 +279,16 @@   test_example_hello() {+  local binary="$ZEOLITE_PATH/example/hello/HelloDemo"+  local name='Cli Tests'+  rm -f "$binary"   do_zeolite -p "$ZEOLITE_PATH" -I lib/util -m HelloDemo example/hello -f-  do_zeolite -p "$ZEOLITE_PATH" -t example/hello+  local output=$(echo "$name" | "$binary" 2>&1)+  if ! echo "$output" | egrep -q "\"$name\""; then+    show_message "Expected \"$name\" in output:"+    echo "$output" 1>&2+    return 1+  fi }  

@@ -57,8 +57,7 @@   testcase "assign if/elif condition" {-  error-  require "value.+initialized"+  compiles }  define Value {@@ -168,6 +167,47 @@       value <- empty     } elif (false) {       value <- empty+    }+  }+}++concrete Value {}+++testcase "return set in predicate for subsequent blocks" {+  compiles+}++define Value {+  @value process () -> (Int)+  process () (x) {+    if (false) {+      x <- 1+    } elif ((x <- 1) > 0) {+      fail(x)+    } else {+    }+  }+}++concrete Value {}++++testcase "return in set in predicates is conditional" {+  error+  require "implicit return"+  require "x.+initialized"+}++define Value {+  @value process () -> (Int)+  process () (x) {+    if (false) {+    } elif ((x <- 1) > 0) {+      fail(x)+    } else {+      fail(x)     }   } }

@@ -156,3 +156,36 @@     return x + y   } }+++testcase "infix function associativity" {+  success+}++unittest test {+  \ Test.check()+}++concrete Test {+  @type check () -> ()+}++define Test {+  check () {+    \ Testing.checkEquals<?>(1 `one` 2 `two` 4,5)+  }++  @type one (Int,Int) -> (Int)+  one (x,y) {+    \ Testing.checkEquals<?>(x,1)+    \ Testing.checkEquals<?>(y,2)+    return 3+  }++  @type two (Int,Int) -> (Int)+  two (x,y) {+    \ Testing.checkEquals<?>(x,3)+    \ Testing.checkEquals<?>(y,4)+    return 5+  }+}

@@ -107,7 +107,7 @@  unittest precedence {   scoped {-    Bool x <- false && false || true+    Bool x <- 1 < 2 && 3 <= 4   } in if (!x) {     fail(x)   }@@ -133,7 +133,21 @@   } } +unittest rightAssociative {+  Int x <- 2+  Bool y <- true && (x <- 3) == 2 || x == 3+  \ Testing.checkEquals<?>(x,3)+  \ Testing.checkEquals<?>(y,true)+} +unittest shortCircuit {+  Int x <- 2+  Bool y <- true || (x <- 3) == 2 || x == 3+  \ Testing.checkEquals<?>(x,2)+  \ Testing.checkEquals<?>(y,true)+}++ testcase "Float operations" {   success }@@ -316,7 +330,7 @@  define Test {   run () {-    \ 1 < 2 < 3+    \ (1 < 2) < 3   } } 

@@ -176,3 +176,86 @@     return "return"   } }+++testcase "Issue #126 is fixed" {+  // https://github.com/ta0kira/zeolite/issues/126+  crash+  require "message,12345,false"+}++unittest test {+  \ Type.call()+}++concrete Type {+  @type call () -> (String,Int,Bool)+}++define Type {+  call () (x,y,z) {+    cleanup {+      // Primitive variables y and z need to be explicitly set separately from+      // the return tuple, since the former are stored separately.+      fail(x + "," + y.formatted() + "," + z.formatted())+    } in return "message", 12345, false+  }+}+++testcase "Issue #127 is fixed: if" {+  // https://github.com/ta0kira/zeolite/issues/127+  error+  require "cleanup"+  require "message.+initialized"+}++unittest test {+  \ Type.call()+}++concrete Type {+  @type call () -> (String)+}++define Type {+  call () (message) {+    cleanup {+      // Using message on the right side of && makes sure that message is still+      // counted as being required, despite possible short-circuiting.+      if (true && message != "message") {+        fail("failed")+      }+    } in {}+    return "return"+  }+}+++testcase "Issue #127 is fixed: while" {+  // https://github.com/ta0kira/zeolite/issues/127+  error+  require "cleanup"+  require "message.+initialized"+}++unittest test {+  \ Type.call()+}++concrete Type {+  @type call () -> (String)+}++define Type {+  call () (message) {+    cleanup {+      // Using message on the right side of && makes sure that message is still+      // counted as being required, despite possible short-circuiting.+      while (true && message != "message") {+        fail("failed")+      }+    } in {}+    return "return"+  }+}

@@ -35,22 +35,6 @@ }  -testcase "assign while condition" {-  error-  require "value.+initialized"-}--@value interface Value {}--concrete Test {}--define Test {-  @value process () -> (optional Value)-  process () (value) {-    while (present((value <- empty))) {}-  }-}- testcase "return while" {   error   require "return"@@ -443,5 +427,27 @@       }     }     return "return"+  }+}+++testcase "return set in predicate" {+  crash+  require "message"+}++unittest test {+  \ Value.process()+}++concrete Value {+  @type process () -> (String)+}++define Value {+  process () (message) {+    while ((message <- "message") != "") {+      fail(message)+    }   } }

@@ -1,7 +1,7 @@ cabal-version:       2.2  name:                zeolite-lang-version:             0.11.0.0+version:             0.12.0.0 synopsis:            Zeolite is a statically-typed, general-purpose programming language.  description: