aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--frontend/check.icl105
1 files changed, 103 insertions, 2 deletions
diff --git a/frontend/check.icl b/frontend/check.icl
index f9d4197..45aa918 100644
--- a/frontend/check.icl
+++ b/frontend/check.icl
@@ -4,7 +4,7 @@ import StdEnv
import syntax, typesupport, parse, checksupport, utilities, checktypes, transform, predef
import explicitimports, comparedefimp, checkFunctionBodies, containers, portToNewSyntax, compilerSwitches
-import RWSDebug
+// import RWSDebug
cUndef :== (-1)
cDummyArray :== {}
@@ -790,6 +790,106 @@ ident_for_errors_from_fun_symb_and_fun_kind {id_name} (FK_Function fun_name_is_l
ident_for_errors_from_fun_symb_and_fun_kind fun_symb _
= fun_symb
+// check that there are no strict lets, mark top-level cases as explicit
+class checkMacro a :: !Bool !a !*ErrorAdmin -> (!a, !*ErrorAdmin)
+
+instance checkMacro [a] | checkMacro a where
+ checkMacro topLevel l ea
+ = mapSt (checkMacro topLevel) l ea
+
+instance checkMacro FunctionBody where
+ checkMacro topLevel (CheckedBody body) ea
+ # (body, ea)
+ = checkMacro topLevel body ea
+ = (CheckedBody body, ea)
+
+instance checkMacro CheckedBody where
+ checkMacro topLevel body=:{cb_rhs} ea
+ # (cb_rhs, ea)
+ = checkMacro topLevel cb_rhs ea
+ = ({body & cb_rhs = cb_rhs}, ea)
+
+instance checkMacro CheckedAlternative where
+ checkMacro topLevel alt=:{ca_rhs} ea
+ # (ca_rhs, ea)
+ = checkMacro topLevel ca_rhs ea
+ = ({alt & ca_rhs = ca_rhs}, ea)
+
+instance checkMacro Expression where
+ checkMacro topLevel (Let lad) ea
+ # (lad, ea)
+ = checkMacro topLevel lad ea
+ = (Let lad, ea)
+ checkMacro topLevel (Case kees) ea
+ # (kees, ea)
+ = checkMacro topLevel kees ea
+ = (Case kees, ea)
+ checkMacro _ expr ea
+ = (expr, ea)
+
+instance checkMacro Let where
+ checkMacro topLevel lad=:{let_strict_binds, let_expr} ea
+ # ea
+ = check_strict_binds let_strict_binds ea
+ # (let_expr, ea)
+ = checkMacro topLevel let_expr ea
+ = ({lad & let_expr = let_expr}, ea)
+ where
+ check_strict_binds [] ea
+ = ea
+ check_strict_binds _ ea
+ = checkError "#! not allowed in macros" "" ea
+
+instance checkMacro Case where
+ checkMacro topLevel kees=:{case_guards, case_explicit} ea
+ # (case_guards, ea)
+ = checkMacro False case_guards ea
+ = ({kees & case_guards = case_guards,case_explicit = topLevel || case_explicit}, ea)
+
+instance checkMacro CasePatterns where
+ checkMacro topLevel (AlgebraicPatterns type patterns) ea
+ # (patterns, ea)
+ = checkMacro topLevel patterns ea
+ = (AlgebraicPatterns type patterns, ea)
+ checkMacro topLevel (BasicPatterns type patterns) ea
+ # (patterns, ea)
+ = checkMacro topLevel patterns ea
+ = (BasicPatterns type patterns, ea)
+ checkMacro topLevel (DynamicPatterns patterns) ea
+ # (patterns, ea)
+ = checkMacro topLevel patterns ea
+ = (DynamicPatterns patterns, ea)
+ checkMacro topLevel (OverloadedListPatterns type decons patterns) ea
+ # (patterns, ea)
+ = checkMacro topLevel patterns ea
+ = (OverloadedListPatterns type decons patterns, ea)
+ checkMacro _ NoPattern ea
+ = (NoPattern, ea)
+
+instance checkMacro AlgebraicPattern where
+ checkMacro topLevel pattern=:{ap_expr} ea
+ # (ap_expr, ea)
+ = checkMacro topLevel ap_expr ea
+ = ({pattern & ap_expr = ap_expr}, ea)
+
+instance checkMacro BasicPattern where
+ checkMacro topLevel pattern=:{bp_expr} ea
+ # (bp_expr, ea)
+ = checkMacro topLevel bp_expr ea
+ = ({pattern & bp_expr = bp_expr}, ea)
+
+instance checkMacro DynamicPattern where
+ checkMacro topLevel pattern=:{dp_rhs} ea
+ # (dp_rhs, ea)
+ = checkMacro topLevel dp_rhs ea
+ = ({pattern & dp_rhs = dp_rhs}, ea)
+
+checkFunctionBodyIfMacro :: !FunKind !FunctionBody !*ErrorAdmin -> (!FunctionBody, !*ErrorAdmin)
+checkFunctionBodyIfMacro FK_Macro def ea
+ = checkMacro True def ea
+checkFunctionBodyIfMacro _ def ea
+ = (def, ea)
+
checkFunction :: !FunDef !Index !FunctionOrMacroIndex !Level !Int !*{#FunDef} !*ExpressionInfo !*Heaps !*CheckState
-> (!FunDef,!*{#FunDef},!*ExpressionInfo,!*Heaps,!*CheckState);
checkFunction fun_def=:{fun_symb,fun_pos,fun_body,fun_type,fun_kind} mod_index fun_index def_level local_functions_index_offset
@@ -808,7 +908,8 @@ checkFunction fun_def=:{fun_symb,fun_pos,fun_body,fun_type,fun_kind} mod_index f
# {es_fun_defs,es_calls,es_var_heap,es_expr_heap,es_type_heaps,es_dynamics} = e_state
(ef_type_defs, ef_modules, es_type_heaps, es_expr_heap, cs) =
checkDynamicTypes mod_index es_dynamics fun_type e_info.ef_type_defs e_info.ef_modules es_type_heaps es_expr_heap cs
- cs = { cs & cs_error = popErrorAdmin cs.cs_error }
+ (fun_body, cs_error) = checkFunctionBodyIfMacro fun_kind fun_body cs.cs_error
+ cs = { cs & cs_error = popErrorAdmin cs_error }
fi_properties = (if ef_is_macro_fun FI_IsMacroFun 0) bitor (has_type fun_type)
fun_info = { fun_def.fun_info & fi_calls = es_calls, fi_def_level = def_level, fi_free_vars = free_vars, fi_dynamics = es_dynamics,
fi_properties = fi_properties }