aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--MacLibraries/CleanCompilerLibbin418374 -> 418883 bytes
-rw-r--r--backend/backend.dcl4
-rw-r--r--backend/backend.icl4
-rw-r--r--backend/backendconvert.icl55
-rw-r--r--backendC/CleanCompilerSources/backend.h4
-rw-r--r--backendC/CleanCompilerSources/codegen3.c24
-rw-r--r--backendC/CleanCompilerSources/instructions.c25
-rw-r--r--backendC/CleanCompilerSources/instructions.h3
-rw-r--r--backendC/backend.mcpbin57399 -> 110822 bytes
-rw-r--r--backendC/backend.rc2
-rw-r--r--coclmaindll/backend.dllbin287232 -> 288256 bytes
-rw-r--r--frontend/convertcases.icl2
12 files changed, 98 insertions, 25 deletions
diff --git a/MacLibraries/CleanCompilerLib b/MacLibraries/CleanCompilerLib
index 80303db..70dc278 100644
--- a/MacLibraries/CleanCompilerLib
+++ b/MacLibraries/CleanCompilerLib
Binary files differ
diff --git a/backend/backend.dcl b/backend/backend.dcl
index 0f5a100..b144aa5 100644
--- a/backend/backend.dcl
+++ b/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;
diff --git a/backend/backend.icl b/backend/backend.icl
index ef7e6ad..ac2c4b2 100644
--- a/backend/backend.icl
+++ b/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;
diff --git a/backend/backendconvert.icl b/backend/backendconvert.icl
index ad5ec69..bea9282 100644
--- a/backend/backendconvert.icl
+++ b/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)
diff --git a/backendC/CleanCompilerSources/backend.h b/backendC/CleanCompilerSources/backend.h
index acfcf3e..004eb88 100644
--- a/backendC/CleanCompilerSources/backend.h
+++ b/backendC/CleanCompilerSources/backend.h
@@ -1,7 +1,7 @@
/* 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
diff --git a/backendC/CleanCompilerSources/codegen3.c b/backendC/CleanCompilerSources/codegen3.c
index b5e6b83..5a5d370 100644
--- a/backendC/CleanCompilerSources/codegen3.c
+++ b/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);
diff --git a/backendC/CleanCompilerSources/instructions.c b/backendC/CleanCompilerSources/instructions.c
index 9e29575..b2d380b 100644
--- a/backendC/CleanCompilerSources/instructions.c
+++ b/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);
diff --git a/backendC/CleanCompilerSources/instructions.h b/backendC/CleanCompilerSources/instructions.h
index 532aee7..8cd809b 100644
--- a/backendC/CleanCompilerSources/instructions.h
+++ b/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);
diff --git a/backendC/backend.mcp b/backendC/backend.mcp
index fdcdf52..eff7faa 100644
--- a/backendC/backend.mcp
+++ b/backendC/backend.mcp
Binary files differ
diff --git a/backendC/backend.rc b/backendC/backend.rc
index 768d7e5..16b1c8f 100644
--- a/backendC/backend.rc
+++ b/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
diff --git a/coclmaindll/backend.dll b/coclmaindll/backend.dll
index 2fa4915..faf8b12 100644
--- a/coclmaindll/backend.dll
+++ b/coclmaindll/backend.dll
Binary files differ
diff --git a/frontend/convertcases.icl b/frontend/convertcases.icl
index aa1682e..4901f0b 100644
--- a/frontend/convertcases.icl
+++ b/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
generated by cgit v1.2.3 (git 2.39.1) at 2025-03-13 19:53:23 +0000