===================================================================
@@ -1411,6 +1411,14 @@ package body Sem_Aggr is
-- Set to False if resolution of the expression failed
begin
+ -- Defend against previous errors
+
+ if Nkind (Expr) = N_Error
+ or else Error_Posted (Expr)
+ then
+ return True;
+ end if;
+
-- If the array type against which we are resolving the aggregate
-- has several dimensions, the expressions nested inside the
-- aggregate must be further aggregates (or strings).
===================================================================
@@ -11252,6 +11252,12 @@ package body Sem_Ch3 is
Rng : Node_Id;
begin
+ -- Defend against previous errors
+
+ if No (Scalar_Range (Derived_Type)) then
+ return;
+ end if;
+
Lo := Build_Scalar_Bound
(Type_Low_Bound (Derived_Type),
Parent_Type, Implicit_Base);
@@ -18294,6 +18300,12 @@ package body Sem_Ch3 is
Kind : constant Entity_Kind := Ekind (Def_Id);
begin
+ -- Defend against previous error
+
+ if Nkind (R) = N_Error then
+ return;
+ end if;
+
Set_Scalar_Range (Def_Id, R);
-- We need to link the range into the tree before resolving it so
===================================================================
@@ -1089,7 +1089,9 @@ package body Freeze is
-- Do not attempt to analyze case where range was in error
- if Error_Posted (Scalar_Range (E)) then
+ if No (Scalar_Range (E))
+ or else Error_Posted (Scalar_Range (E))
+ then
return;
end if;
===================================================================
@@ -4680,9 +4680,9 @@ package body Sem_Eval is
-- If there was an error in either range, then just assume the types
-- statically match to avoid further junk errors.
- if Error_Posted (Scalar_Range (T1))
- or else
- Error_Posted (Scalar_Range (T2))
+ if No (Scalar_Range (T1)) or else No (Scalar_Range (T2))
+ or else Error_Posted (Scalar_Range (T1))
+ or else Error_Posted (Scalar_Range (T2))
then
return True;
end if;
===================================================================
@@ -4994,7 +4994,10 @@ package body Exp_Ch3 is
and then No_Initialization (Expr)
then
null;
- else
+
+ -- Otherwise apply a constraint check now if no prev error
+
+ elsif Nkind (Expr) /= N_Error then
Apply_Constraint_Check (Expr, Typ);
-- If the expression has been marked as requiring a range
This patch adds some defenses against junk code, avoiding crashes The following tests compile with syntax errors instead of crashing with ATower; use ATower; package TowersOfHanoi is type TowersRange is (left, middle, right); type TowersPool is array (TowersRange) of Tower; type TowersBoard is record pool : TowersPool := (left => Tower'(empty => false, top => Disc'Last, buf => (Disc'First .. Disc'Last))); end record; end TowersOfHanoi; package ATower is type Disc is new Natural range 0 .. 3; type TowerBuffer is array (Disc) of Disc; type Tower is record empty : Boolean := true; top : Disc := Disc'First; buf : TowerBuffer; end record; emptyTower : constant Tower := (empty => true, top => Disc'First, buf => (others => Disc'First)); procedure push(tower : in out ATower.Tower; val : Integer); procedure pop(tower : in out ATower.Tower); function top(tower : ATower.Tower) return Integer; function isEmpty(tower : ATower.Tower) return Boolean; underflow : exception; -- Stack underflow overflow : exception; -- Stack overflow end ATower; package Toto is type Disc is new Natural range (0 .. 3); end Toto; Tested on x86_64-pc-linux-gnu, committed on trunk 2010-09-10 Robert Dewar <dewar@adacore.com> * exp_ch3.adb (Expand_N_Object_Declaration): Defend against previous errors. * freeze.adb (Check_Unsigned_Type): Ditto. * sem_aggr.adb (Resolve_Aggr_Expr): Ditto. * sem_ch3.adb (Convert_Scalar_Bounds): Ditto. (Set_Scalar_Range_For_Subtype): Ditto. * sem_eval.adb (Subtypes_Statically_Match): Ditto.