Commit 60812627 authored by Ronny Wichers Schreur's avatar Ronny Wichers Schreur

fail explicit cases

parent 636fe443
......@@ -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;
......
......@@ -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;
......
......@@ -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)
......
/* 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
......
......@@ -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);
......
......@@ -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);
......
......@@ -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);
......
No preview for this file type
......@@ -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
......
No preview for this file type
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment