fail explicit cases

backend/backend.dcl

@@ -279,9 +279,9 @@ BEDeclareDynamicTypeSymbol :: !Int !Int !BackEnd -> BackEnd;
 // void BEDeclareDynamicTypeSymbol (int typeIndex,int moduleIndex);
 BEDynamicTempTypeSymbol :: !BackEnd -> (!BESymbolP,!BackEnd);
 // BESymbolP BEDynamicTempTypeSymbol ();
-kBEVersionCurrent:==0x02000213;
+kBEVersionCurrent:==0x02000214;
 kBEVersionOldestDefinition:==0x02000213;
-kBEVersionOldestImplementation:==0x02000213;
+kBEVersionOldestImplementation:==0x02000214;
 kBEDebug:==1;
 kPredefinedModuleIndex:==1;
 BENoAnnot:==0;

backend/backend.icl

@@ -763,9 +763,9 @@ BEDynamicTempTypeSymbol a0 = code {
 	ccall BEDynamicTempTypeSymbol ":I:I"
 };
 // BESymbolP BEDynamicTempTypeSymbol ();
-kBEVersionCurrent:==0x02000213;
+kBEVersionCurrent:==0x02000214;
 kBEVersionOldestDefinition:==0x02000213;
-kBEVersionOldestImplementation:==0x02000213;
+kBEVersionOldestImplementation:==0x02000214;
 kBEDebug:==1;
 kPredefinedModuleIndex:==1;
 BENoAnnot:==0;

backend/backendconvert.icl

@@ -1605,7 +1605,7 @@ convertBackEndLhs functionIndex patterns main_dcl_module_n
 convertStrings :: [{#Char}] -> BEMonad BEStringListP
 convertStrings strings
 	=	sfoldr (beStrings o beString) beNoStrings strings
-
+ 
 convertCodeParameters :: (CodeBinding a) -> BEMonad BECodeParameterP | varInfoPtr a
 convertCodeParameters codeParameters
 	=	sfoldr (beCodeParameters o convertCodeParameter) beNoCodeParameters codeParameters
@@ -1686,11 +1686,23 @@ convertRootExpr aliasDummyId (Conditional {if_cond=cond, if_then=then, if_else=N
 				beNoNodeDefs
 				beNoStrictNodeIds
 				(beNormalNode (beBasicSymbol BEFailSymb) beNoArgs)
-convertRootExpr aliasDummyId (Case {case_expr, case_guards, case_default}) main_dcl_module_n
-	=	beSwitchNode (convertVar var.var_info_ptr) (convertCases case_guards aliasDummyId var case_default main_dcl_module_n)
+convertRootExpr aliasDummyId (Case kees=:{case_expr, case_guards}) main_dcl_module_n
+	=	beSwitchNode (convertVar var.var_info_ptr) (convertCases case_guards aliasDummyId var (defaultCase kees) main_dcl_module_n)
 	where
 		var
 			=	caseVar case_expr
+
+		defaultCase {case_default=Yes defaul} 
+			=	DefaultCase defaul
+		defaultCase {case_explicit, case_default=No, case_ident}
+			| case_explicit
+			 	=	case case_ident of
+			 			Yes ident
+			 				->	DefaultCaseFail ident
+			 			_
+			 				->	abort "backendconvert:defaultCase, case without id"
+			// otherwise
+			 	=	DefaultCaseNone
 convertRootExpr _ expr main_dcl_module_n
 	=	convertExpr expr main_dcl_module_n
 
@@ -1948,7 +1960,12 @@ caseVar (Var var)
 caseVar expr
 	=	undef // <<- ("backendconvert, caseVar: unknown expression", expr)
 
-class convertCases a :: a Ident BoundVar (Optional Expression) Int -> BEMonad BEArgP
+:: DefaultCase
+	=	DefaultCase Expression
+	|	DefaultCaseFail !Ident
+	|	DefaultCaseNone
+
+class convertCases a :: a Ident BoundVar DefaultCase Int -> BEMonad BEArgP
 
 instance convertCases CasePatterns where
 	convertCases (AlgebraicPatterns _ patterns) aliasDummyId var default_case main_dcl_module_n
@@ -1963,11 +1980,14 @@ instance convertCases [a] | convertCase a where
 	convertCases patterns aliasDummyId var optionalCase main_dcl_module_n
 		=	sfoldr (beArgs o convertCase main_dcl_module_n (localRefCounts patterns optionalCase)
 						 aliasDummyId var) (convertDefaultCase optionalCase aliasDummyId main_dcl_module_n) patterns
-	where
-		localRefCounts [x] No
-			=	False
-		localRefCounts _ _
-			=	True
+
+localRefCounts :: [pattern] DefaultCase -> Bool
+localRefCounts [_] DefaultCaseNone
+	=	False
+localRefCounts [_] (DefaultCaseFail _)
+	=	False
+localRefCounts _ _
+	=	True
 
 class convertCase a :: Int Bool Ident BoundVar a -> BEMonad BENodeP
 
@@ -2073,11 +2093,6 @@ convertOverloadedListPatterns patterns decons_expr aliasDummyId var optionalCase
 	=	sfoldr (beArgs o convertOverloadedListPattern decons_expr (localRefCounts patterns optionalCase))
 				(convertDefaultCase optionalCase aliasDummyId main_dcl_module_n) patterns
 where
-	localRefCounts [x] No
-		=	False
-	localRefCounts _ _
-		=	True
-
 	convertOverloadedListPattern :: Expression Bool AlgebraicPattern -> BEMonad BENodeP
 	convertOverloadedListPattern decons_expr localRefCounts {ap_symbol={glob_module,glob_object={ds_index}}, ap_vars=[], ap_expr}
 		=	caseNode localRefCounts 0
@@ -2117,10 +2132,16 @@ convertPatternVar :: FreeVar -> BEMonad BENodeIdListP
 convertPatternVar freeVar
 	=	beNodeIdListElem (convertVar freeVar.fv_info_ptr)
 
-convertDefaultCase :: (Optional Expression) Ident Int -> BEMonad BEArgP
-convertDefaultCase No _ _
+convertDefaultCase DefaultCaseNone _ _
 	=	beNoArgs
-convertDefaultCase (Yes expr) aliasDummyId main_dcl_module_n
+convertDefaultCase (DefaultCaseFail ident) aliasDummyId main_dcl_module_n
+	=	beArgs
+			(defaultNode
+				beNoNodeDefs
+				beNoStrictNodeIds
+				(beNormalNode (beLiteralSymbol BEFailSymb ident.id_name) beNoArgs))
+			beNoArgs
+convertDefaultCase (DefaultCase expr) aliasDummyId main_dcl_module_n
 	=	beArgs
 			(defaultNode
 				(convertRhsNodeDefs aliasDummyId expr main_dcl_module_n)

backendC/CleanCompilerSources/backend.h

 /* version info */
 
 // increment this for every release
-# define	kBEVersionCurrent				0x02000213
+# define	kBEVersionCurrent				0x02000214
 
 // change this to the same value as kBEVersionCurrent if the new release is not
 // upward compatible (for example when a function is added)
@@ -9,7 +9,7 @@
 
 // change this to the same value as kBEVersionCurrent if the new release is not
 // downward compatible (for example when a function is removed)
-# define	kBEVersionOldestImplementation	0x02000213
+# define	kBEVersionOldestImplementation	0x02000214
 
 
 # define	kBEDebug	1

backendC/CleanCompilerSources/codegen3.c

@@ -860,9 +860,33 @@ static void CodeNormalRootNode (Node root,NodeId rootid,int asp,int bsp,CodeGenN
 			CodeRootSelection (root, rootid, asp, bsp,code_gen_node_ids_p,resultstate);
 			return;
 		case fail_symb:
+#if CLEAN2
+		{
+			IdentS case_ident_s;
+			SymbDefS case_def_s;
+
+			case_ident_s.ident_name=rootsymb->symb_string;
+			Assume (case_ident_s.ident_name != NULL, "codegen3", "CodeNormalRootNode (fail_symb)");
+
+			case_def_s.sdef_ident = &case_ident_s;
+			case_def_s.sdef_line = 0;
+
+			StaticMessage (FunctionMayFailIsError, "%D", "case may fail", &case_def_s);
+
+			if (! (IsOnBStack (resultstate) || 
+						(IsSimpleState (resultstate) && resultstate.state_kind==StrictRedirection)))
+				/* root needed */
+				asp++;
+
+			GenCaseNoMatchError (&case_def_s,asp,bsp);
+
+			return;
+		}
+#else /* ifndef CLEAN2 */
 			error_in_function ("CodeNormalRootNode");
 /*			JumpToNextAlternative (asp, bsp); */
 			return;
+#endif
 		case string_denot:
 			GenPopA (asp);
 			GenPopB (bsp);

backendC/CleanCompilerSources/instructions.c

@@ -3393,6 +3393,31 @@ void GenNoMatchError (SymbDef sdef,int asp,int bsp,int string_already_generated)
 	}
 }
 
+#if CLEAN2
+void GenCaseNoMatchError (SymbDefP case_def,int asp,int bsp)
+{
+	static int case_number;
+
+	GenPopA (asp);
+	GenPopB (bsp);
+
+	put_instruction_b (pushD);
+	FPrintF (OutFile, "m_%s", CurrentModule);
+
+	put_instruction_b (pushD);
+	FPrintF (OutFile, "case_fail%u",case_number);
+
+	GenJmp (&match_error_lab);
+	
+	put_directive_ (Dstring);
+	FPrintF (OutFile, "case_fail%u \"",case_number);		
+	PrintSymbolOfIdent (case_def->sdef_ident,case_def->sdef_line,OutFile);
+	FPrintF (OutFile, "\"");		
+
+	case_number++;
+}
+#endif
+
 static void GenImpLab (char *label_name)
 {
 	put_directive_b (implab);

backendC/CleanCompilerSources/instructions.h

@@ -187,6 +187,9 @@ void InitFileInfo (ImpMod imod);
 /* void GenFileInfo (void); */
 
 void GenNoMatchError (SymbDef sdef,int asp,int bsp,int string_already_generated);
+#if CLEAN2
+void GenCaseNoMatchError (SymbDefP case_def,int asp,int bsp);
+#endif
 
 void InitInstructions (void);
 

backendC/backend.rc

@@ -37,7 +37,7 @@ BEGIN
 			VALUE "LegalTrademarks", "\0"
 			VALUE "OriginalFilename","backend.dll\0"
 			VALUE "ProductName",     "Clean System"
-			VALUE "ProductVersion",  "2.0.d.12"
+			VALUE "ProductVersion",  "2.0.d.0"
 			VALUE "OLESelfRegister", "\0"
 		END
 	

frontend/convertcases.icl

@@ -1083,7 +1083,7 @@ convertNonRootCase ci=:{ci_bound_vars, ci_group_index, ci_common_defs} kees=:{ c
 	  case_free_var = {	fv_def_level = NotALevel, fv_name = var_id, fv_info_ptr = new_info_ptr, fv_count = 0}
 	  cs = { cs & cs_var_heap = cs_var_heap}
 
-	  kees = {kees & case_expr=case_var}
+	  kees = {kees & case_expr=case_var, case_explicit=False}
 
 	  (case_expr, cs) = convertCases ci case_expr cs