diff --git a/gcc/m2/gm2-compiler/M2Base.mod b/gcc/m2/gm2-compiler/M2Base.mod
index 04a0e4e42637e6cc09d36800f4882fcc2195f40e..b8677695bfd40b1e7919f46dcbba802b3683b0a3 100644
--- a/gcc/m2/gm2-compiler/M2Base.mod
+++ b/gcc/m2/gm2-compiler/M2Base.mod
@@ -85,7 +85,8 @@ FROM M2Size IMPORT Size, MakeSize ;
FROM M2System IMPORT Address, Byte, Word, System, Loc, InitSystem,
IntegerN, CardinalN, WordN, SetN, RealN, ComplexN,
IsCardinalN, IsIntegerN, IsRealN, IsComplexN,
- IsGenericSystemType, IsSameSizePervasiveType ;
+ IsGenericSystemType, IsSameSizePervasiveType,
+ IsSystemType ;
FROM M2Options IMPORT NilChecking,
WholeDivChecking, WholeValueChecking,
@@ -1990,7 +1991,7 @@ BEGIN
mt2 := FindMetaType(t2) ;
CASE Expr[mt1, mt2] OF
- no : MetaErrorT2 (NearTok, 'type incompatibility between {%1as} and {%2as}', t1, t2) ;
+ no : MetaErrorT2 (NearTok, 'type incompatibility between {%1asd} and {%2asd}', t1, t2) ;
FlushErrors (* unrecoverable at present *) |
warnfirst,
first : RETURN( t1 ) |
@@ -2004,6 +2005,16 @@ BEGIN
END MixMetaTypes ;
+(*
+ IsUserType - return TRUE if type was created by the user as a synonym.
+*)
+
+PROCEDURE IsUserType (type: CARDINAL) : BOOLEAN ;
+BEGIN
+ RETURN IsType (type) AND (NOT IsBaseType (type)) AND (NOT IsSystemType (type))
+END IsUserType ;
+
+
(*
MixTypes - given types, t1 and t2, returns a type symbol that
provides expression type compatibility.
@@ -2074,10 +2085,10 @@ BEGIN
ELSE
RETURN( CType )
END
- ELSIF IsType(t1)
+ ELSIF IsUserType (t1)
THEN
RETURN( MixTypes(GetType(t1), t2, NearTok) )
- ELSIF IsType(t2)
+ ELSIF IsUserType (t2)
THEN
RETURN( MixTypes(t1, GetType(t2), NearTok) )
ELSIF (t1=GetLowestType(t1)) AND (t2=GetLowestType(t2))
diff --git a/gcc/m2/gm2-compiler/M2GenGCC.mod b/gcc/m2/gm2-compiler/M2GenGCC.mod
index 92ca39f71b5882c6003fa17c045c31a1914eb74b..25bfbf894aa7bd4d1b94f85768d99fdea864c6aa 100644
--- a/gcc/m2/gm2-compiler/M2GenGCC.mod
+++ b/gcc/m2/gm2-compiler/M2GenGCC.mod
@@ -76,7 +76,7 @@ FROM SymbolTable IMPORT PushSize, PopSize, PushValue, PopValue,
GetPriority, GetNeedSavePriority,
PutConstString,
PutConst, PutConstSet, PutConstructor,
- GetSType,
+ GetSType, GetTypeMode,
HasVarParameters,
NulSym ;
@@ -2943,21 +2943,6 @@ BEGIN
END DefaultConvertGM2 ;
-(*
- GetTypeMode -
-*)
-
-PROCEDURE GetTypeMode (sym: CARDINAL) : CARDINAL ;
-BEGIN
- IF GetMode(sym)=LeftValue
- THEN
- RETURN( Address )
- ELSE
- RETURN( GetType(sym) )
- END
-END GetTypeMode ;
-
-
(*
FoldConstBecomes - returns a Tree containing op3.
The tree will have been folded and
@@ -3523,7 +3508,7 @@ BEGIN
DeclareConstant (op2pos, op2) ;
location := TokenToLocation (op1pos) ;
- type := MixTypes (FindType (op2), FindType (op3), op3pos) ;
+ type := MixTypesBinary (op2, op3, op1pos, MustCheckOverflow (quad)) ;
ConvertBinaryOperands (location, tl, tr, type, op2, op3) ;
lowestType := GetLType (op1) ;
@@ -3553,6 +3538,23 @@ BEGIN
END CodeBinaryCheck ;
+(*
+ MixTypesBinary - depending upon check do not check pointer arithmetic.
+*)
+
+PROCEDURE MixTypesBinary (left, right: CARDINAL;
+ tokpos: CARDINAL; check: BOOLEAN) : CARDINAL ;
+BEGIN
+ IF (NOT check) AND
+ (IsPointer (GetTypeMode (left)) OR IsPointer (GetTypeMode (right)))
+ THEN
+ RETURN Address
+ ELSE
+ RETURN MixTypes (FindType (left), FindType (right), tokpos)
+ END
+END MixTypesBinary ;
+
+
(*
CodeBinary - encode a binary arithmetic operation.
*)
@@ -3576,7 +3578,7 @@ BEGIN
DeclareConstant (op2pos, op2) ;
location := TokenToLocation (op1pos) ;
- type := MixTypes (FindType (op2), FindType (op3), op1pos) ;
+ type := MixTypesBinary (op2, op3, op1pos, MustCheckOverflow (quad)) ;
ConvertBinaryOperands (location, tl, tr, type, op2, op3) ;
tv := binop (location, tl, tr, FALSE) ;
@@ -6742,9 +6744,9 @@ BEGIN
ELSE
ConvertBinaryOperands(location,
tl, tr,
- MixTypes(SkipType(GetType(op1)),
- SkipType(GetType(op2)),
- CurrentQuadToken),
+ ComparisonMixTypes (SkipType (GetType (op1)),
+ SkipType (GetType (op2)),
+ CurrentQuadToken),
op1, op2) ;
DoJump(location,
BuildLessThan(location, tl, tr), NIL, string(CreateLabelName(op3)))
@@ -6839,9 +6841,9 @@ BEGIN
ELSE
ConvertBinaryOperands(location,
tl, tr,
- MixTypes(SkipType(GetType(op1)),
- SkipType(GetType(op2)),
- CurrentQuadToken),
+ ComparisonMixTypes (SkipType (GetType (op1)),
+ SkipType (GetType (op2)),
+ CurrentQuadToken),
op1, op2) ;
DoJump(location, BuildGreaterThan(location, tl, tr), NIL, string(CreateLabelName(op3)))
END
@@ -6935,9 +6937,9 @@ BEGIN
ELSE
ConvertBinaryOperands(location,
tl, tr,
- MixTypes(SkipType(GetType(op1)),
- SkipType(GetType(op2)),
- CurrentQuadToken),
+ ComparisonMixTypes (SkipType (GetType (op1)),
+ SkipType (GetType (op2)),
+ CurrentQuadToken),
op1, op2) ;
DoJump(location, BuildLessThanOrEqual(location, tl, tr), NIL, string(CreateLabelName(op3)))
END
@@ -7031,9 +7033,9 @@ BEGIN
ELSE
ConvertBinaryOperands(location,
tl, tr,
- MixTypes(SkipType(GetType(op1)),
- SkipType(GetType(op2)),
- CurrentQuadToken),
+ ComparisonMixTypes (SkipType (GetType (op1)),
+ SkipType (GetType (op2)),
+ CurrentQuadToken),
op1, op2) ;
DoJump(location, BuildGreaterThanOrEqual(location, tl, tr), NIL, string(CreateLabelName(op3)))
END
@@ -7146,6 +7148,24 @@ BEGIN
END CodeIfSetNotEqu ;
+(*
+ ComparisonMixTypes -
+*)
+
+PROCEDURE ComparisonMixTypes (left, right: CARDINAL; tokpos: CARDINAL) : CARDINAL ;
+BEGIN
+ IF IsGenericSystemType (left)
+ THEN
+ RETURN left
+ ELSIF IsGenericSystemType (right)
+ THEN
+ RETURN right
+ ELSE
+ RETURN MixTypes (left, right, tokpos)
+ END
+END ComparisonMixTypes ;
+
+
(*
CodeIfEqu - codes the quadruple if op1 = op2 then goto op3
*)
@@ -7185,9 +7205,9 @@ BEGIN
ELSE
ConvertBinaryOperands(location,
tl, tr,
- MixTypes(SkipType(GetType(op1)),
- SkipType(GetType(op2)),
- CurrentQuadToken),
+ ComparisonMixTypes (SkipType (GetType (op1)),
+ SkipType (GetType (op2)),
+ CurrentQuadToken),
op1, op2) ;
DoJump(location, BuildEqualTo(location, tl, tr), NIL, string(CreateLabelName(op3)))
END
@@ -7234,9 +7254,9 @@ BEGIN
ELSE
ConvertBinaryOperands(location,
tl, tr,
- MixTypes(SkipType(GetType(op1)),
- SkipType(GetType(op2)),
- CurrentQuadToken),
+ ComparisonMixTypes (SkipType (GetType (op1)),
+ SkipType (GetType (op2)),
+ CurrentQuadToken),
op1, op2) ;
DoJump(location,
BuildNotEqualTo(location, tl, tr), NIL, string(CreateLabelName(op3)))
diff --git a/gcc/m2/gm2-compiler/M2Quads.mod b/gcc/m2/gm2-compiler/M2Quads.mod
index a666a4e3a5bdf17c7155fbc42fb09d43ab0384c8..a23fa32906e4964a20d7e27011df1d72233f1561 100644
--- a/gcc/m2/gm2-compiler/M2Quads.mod
+++ b/gcc/m2/gm2-compiler/M2Quads.mod
@@ -132,6 +132,7 @@ FROM SymbolTable IMPORT ModeOfAddr, GetMode, PutMode, GetSymName, IsUnknown,
ForeachFieldEnumerationDo, ForeachLocalSymDo,
GetExported, PutImported, GetSym, GetLibName,
+ GetTypeMode,
IsUnused,
NulSym ;
@@ -266,7 +267,7 @@ IMPORT M2Error ;
CONST
DebugStackOn = TRUE ;
DebugVarients = FALSE ;
- BreakAtQuad = 53 ;
+ BreakAtQuad = 189 ;
DebugTokPos = FALSE ;
TYPE
@@ -4628,9 +4629,11 @@ BEGIN
is counting down. The above test will generate a more
precise error message, so we suppress overflow detection
here. *)
- GenQuadO (bytok, AddOp, tsym, tsym, BySym, FALSE) ;
+ GenQuadOtok (bytok, AddOp, tsym, tsym, BySym, FALSE,
+ bytok, bytok, bytok) ;
CheckPointerThroughNil (idtok, IdSym) ;
- GenQuadO (idtok, XIndrOp, IdSym, GetSType (IdSym), tsym, FALSE)
+ GenQuadOtok (idtok, XIndrOp, IdSym, GetSType (IdSym), tsym, FALSE,
+ idtok, idtok, idtok)
ELSE
BuildRange (InitForLoopEndRangeCheck (IdSym, BySym)) ;
IncQuad := NextQuad ;
@@ -4639,7 +4642,8 @@ BEGIN
is counting down. The above test will generate a more
precise error message, so we suppress overflow detection
here. *)
- GenQuadO (idtok, AddOp, IdSym, IdSym, BySym, FALSE)
+ GenQuadOtok (idtok, AddOp, IdSym, IdSym, BySym, FALSE,
+ bytok, bytok, bytok)
END ;
GenQuadO (endpostok, GotoOp, NulSym, NulSym, ForQuad, FALSE) ;
BackPatch (PopFor (), NextQuad) ;
@@ -7104,6 +7108,11 @@ VAR
BEGIN
dtype := GetDType(des) ;
etype := GetDType(expr) ;
+ IF (etype = NulSym) AND IsPointer (GetTypeMode (des))
+ THEN
+ expr := ConvertToAddress (tokenpos, expr) ;
+ etype := Address
+ END ;
IF WholeValueChecking AND (NOT MustNotCheckBounds)
THEN
IF tok=PlusTok
@@ -7966,6 +7975,7 @@ VAR
combinedtok,
functok,
optok : CARDINAL ;
+ opa,
ReturnVar,
NoOfParam,
OperandSym,
@@ -7986,7 +7996,9 @@ BEGIN
THEN
ReturnVar := MakeTemporary (combinedtok, RightValue) ;
PutVar (ReturnVar, Address) ;
- GenQuad (AddOp, ReturnVar, VarSym, DereferenceLValue (optok, OperandSym)) ;
+ opa := ConvertToAddress (optok, DereferenceLValue (optok, OperandSym)) ;
+ GenQuadOtok (combinedtok, AddOp, ReturnVar, VarSym, opa, TRUE,
+ combinedtok, combinedtok, combinedtok) ;
PushTFtok (ReturnVar, Address, combinedtok)
ELSE
MetaErrorT1 (functok,
@@ -8041,6 +8053,7 @@ VAR
ReturnVar,
NoOfParam,
OperandSym,
+ opa,
VarSym : CARDINAL ;
BEGIN
PopT (NoOfParam) ;
@@ -8059,7 +8072,9 @@ BEGIN
THEN
ReturnVar := MakeTemporary (combinedtok, RightValue) ;
PutVar (ReturnVar, Address) ;
- GenQuad (SubOp, ReturnVar, VarSym, DereferenceLValue (optok, OperandSym)) ;
+ opa := ConvertToAddress (optok, DereferenceLValue (optok, OperandSym)) ;
+ GenQuadOtok (combinedtok, SubOp, ReturnVar, VarSym, opa, TRUE,
+ combinedtok, combinedtok, combinedtok) ;
PushTFtok (ReturnVar, Address, combinedtok)
ELSE
MetaErrorT1 (functok,
@@ -8119,6 +8134,7 @@ VAR
TempVar,
NoOfParam,
OperandSym,
+ opa,
VarSym : CARDINAL ;
BEGIN
PopT (NoOfParam) ;
@@ -8139,7 +8155,9 @@ BEGIN
THEN
TempVar := MakeTemporary (vartok, RightValue) ;
PutVar (TempVar, Address) ;
- GenQuad (SubOp, TempVar, VarSym, DereferenceLValue (optok, OperandSym)) ;
+ opa := ConvertToAddress (optok, DereferenceLValue (optok, OperandSym)) ;
+ GenQuadOtok (combinedtok, SubOp, TempVar, VarSym, opa, TRUE,
+ combinedtok, combinedtok, combinedtok) ;
(*
Build macro: CONVERT( INTEGER, TempVar )
*)
@@ -10281,10 +10299,12 @@ BEGIN
IF IsAModula2Type (OperandT (1))
THEN
ReturnVar := MakeTemporary (resulttok, ImmediateValue) ;
+ PutVar (ReturnVar, Cardinal) ;
GenQuadO (resulttok, SizeOp, ReturnVar, NulSym, OperandT (1), FALSE)
ELSIF IsVar (OperandT (1))
THEN
ReturnVar := MakeTemporary (resulttok, ImmediateValue) ;
+ PutVar (ReturnVar, Cardinal) ;
GenQuadO (resulttok, SizeOp, ReturnVar, NulSym, GetSType (OperandT (1)), FALSE)
ELSE
MetaErrorT1 (resulttok,
@@ -10307,6 +10327,7 @@ BEGIN
paramtok := OperandTtok (1) ;
resulttok := MakeVirtualTok (functok, functok, paramtok) ;
ReturnVar := MakeTemporary (resulttok, ImmediateValue) ;
+ PutVar (ReturnVar, Cardinal) ;
GenQuadO (resulttok, SizeOp, ReturnVar, NulSym, Record, FALSE)
ELSE
resulttok := MakeVirtualTok (functok, functok, paramtok) ;
@@ -11212,7 +11233,8 @@ BEGIN
GenHigh (tok, tk, dim, arraySym) ;
tl := MakeTemporary (tok, RightValue) ;
PutVar (tl, Cardinal) ;
- GenQuadO (tok, AddOp, tl, tk, MakeConstLit (tok, MakeKey ('1'), Cardinal), TRUE) ;
+ GenQuadOtok (tok, AddOp, tl, tk, MakeConstLit (tok, MakeKey ('1'), Cardinal), TRUE,
+ tok, tok, tok) ;
tj := calculateMultipicand (tok, arraySym, arrayType, dim) ;
ti := MakeTemporary (tok, RightValue) ;
PutVar (ti, Cardinal) ;
@@ -11222,6 +11244,29 @@ BEGIN
END calculateMultipicand ;
+(*
+ ConvertToAddress - convert sym to an address.
+*)
+
+PROCEDURE ConvertToAddress (tokpos: CARDINAL; sym: CARDINAL) : CARDINAL ;
+VAR
+ adr: CARDINAL ;
+BEGIN
+ IF GetSType (sym) = Address
+ THEN
+ RETURN sym
+ ELSE
+ PushTF (RequestSym (tokpos, MakeKey ('CONVERT')), NulSym) ;
+ PushT (Address) ;
+ PushTtok (sym, tokpos) ;
+ PushT(2) ; (* Two parameters *)
+ BuildConvertFunction ;
+ PopT (adr) ;
+ RETURN adr
+ END
+END ConvertToAddress ;
+
+
(*
BuildDynamicArray - Builds the array referencing for dynamic arrays.
The Stack is expected to contain:
@@ -11259,7 +11304,8 @@ VAR
PtrToBase,
Base,
Dim, rw,
- ti, tj, tk : CARDINAL ;
+ ti, tj, tk,
+ tka : CARDINAL ;
BEGIN
DisplayStack ;
Sym := OperandT (2) ;
@@ -11349,19 +11395,23 @@ BEGIN
*)
BackEndType := MakePointer (combinedTok, NulName) ;
PutPointer (BackEndType, GetSType (Type)) ;
+ (* Create a temporary pointer for addition. *)
+ tka := ConvertToAddress (combinedTok, tk) ;
IF Dim = GetDimension (Type)
THEN
PutLeftValueFrontBackType (Adr, GetSType(Type), BackEndType) ;
- GenQuad (AddOp, Adr, Base, tk) ;
+ GenQuadOtok (combinedTok, AddOp, Adr, Base, tka, FALSE,
+ combinedTok, combinedTok, combinedTok) ;
PopN (2) ;
PushTFADrwtok (Adr, GetSType(Adr), ArraySym, Dim, rw, combinedTok)
ELSE
(* more to index *)
PutLeftValueFrontBackType (Adr, Type, BackEndType) ;
- GenQuad (AddOp, Adr, Base, tk) ;
+ GenQuadOtok (combinedTok, AddOp, Adr, Base, tka, FALSE,
+ combinedTok, combinedTok, combinedTok) ;
PopN (2) ;
PushTFADrwtok (Adr, GetSType(Adr), ArraySym, Dim, rw, combinedTok)
END
diff --git a/gcc/m2/gm2-compiler/SymbolTable.def b/gcc/m2/gm2-compiler/SymbolTable.def
index 958591abdf92ad68b5c08640078cd5bc2e5af918..6cbc5c29fe427d6dfa3b099cb34ad18f6a8e3fa3 100644
--- a/gcc/m2/gm2-compiler/SymbolTable.def
+++ b/gcc/m2/gm2-compiler/SymbolTable.def
@@ -105,7 +105,7 @@ EXPORT QUALIFIED NulSym,
AddSymToModuleScope,
GetType, GetLType, GetSType, GetDType,
SkipType, SkipTypeAndSubrange,
- GetLowestType,
+ GetLowestType, GetTypeMode,
GetSym, GetLocalSym, GetDeclareSym, GetRecord,
FromModuleGetSym,
GetOAFamily,
@@ -1174,6 +1174,14 @@ PROCEDURE GetSType (sym: CARDINAL) : CARDINAL ;
PROCEDURE GetDType (sym: CARDINAL) : CARDINAL ;
+(*
+ GetTypeMode - return the type of sym, it returns Address is the
+ symbol is a LValue.
+*)
+
+PROCEDURE GetTypeMode (sym: CARDINAL) : CARDINAL ;
+
+
(*
GetSym - searches the current scope (and previous scopes if the
scope tranparent allows) for a symbol with Name.
diff --git a/gcc/m2/gm2-compiler/SymbolTable.mod b/gcc/m2/gm2-compiler/SymbolTable.mod
index d939d581a6404c1e72a740b17fdcf57074a747f0..7cef7ee1e4388e33870951de0f3b5834be646ed9 100644
--- a/gcc/m2/gm2-compiler/SymbolTable.mod
+++ b/gcc/m2/gm2-compiler/SymbolTable.mod
@@ -112,6 +112,8 @@ CONST
UnboundedAddressName = "_m2_contents" ;
UnboundedHighName = "_m2_high_%d" ;
+ BreakSym = 5293 ;
+
TYPE
ConstLitPoolEntry = POINTER TO RECORD
sym : CARDINAL ;
@@ -1014,6 +1016,14 @@ BEGIN
END FinalSymbol ;
+(*
+ stop - a debugger convenience hook.
+*)
+
+PROCEDURE stop ;
+END stop ;
+
+
(*
NewSym - Sets Sym to a new symbol index.
*)
@@ -1028,6 +1038,10 @@ BEGIN
SymbolType := DummySym
END ;
PutIndice(Symbols, sym, pSym) ;
+ IF sym = BreakSym
+ THEN
+ stop
+ END ;
INC(FreeSymbol)
END NewSym ;
@@ -6602,6 +6616,22 @@ BEGIN
END GetConstLitType ;
+(*
+ GetTypeMode - return the type of sym, it returns Address is the
+ symbol is a LValue.
+*)
+
+PROCEDURE GetTypeMode (sym: CARDINAL) : CARDINAL ;
+BEGIN
+ IF GetMode (sym) = LeftValue
+ THEN
+ RETURN( Address )
+ ELSE
+ RETURN( GetType (sym) )
+ END
+END GetTypeMode ;
+
+
(*
GetLocalSym - only searches the scope Sym for a symbol with name
and returns the index to the symbol.
diff --git a/gcc/m2/gm2-libs/SArgs.mod b/gcc/m2/gm2-libs/SArgs.mod
index b1996cc4591ad9d3b7b720fe5de1482d759c9086..d6cb448d497a2f7a2726ce13db49a648b2ec13a5 100644
--- a/gcc/m2/gm2-libs/SArgs.mod
+++ b/gcc/m2/gm2-libs/SArgs.mod
@@ -65,10 +65,8 @@ BEGIN
i := VAL (INTEGER, n) ;
IF i < GetArgC ()
THEN
- (* ppc := ADDRESS (VAL (PtrToPtrToChar, ArgV) + (i * CARDINAL (TSIZE(PtrToChar)))) ; *)
- ppc := ADDRESS (PtrToChar (GetArgV ()) + (n * TSIZE (PtrToChar))) ;
+ ppc := ADDRESS (ADDRESS (GetArgV ()) + (n * TSIZE (PtrToChar))) ;
s := InitStringCharStar (ppc^) ;
-
RETURN TRUE
ELSE
s := NIL ;
diff --git a/gcc/testsuite/gm2/extensions/fail/arith1.mod b/gcc/testsuite/gm2/extensions/fail/arith1.mod
new file mode 100644
index 0000000000000000000000000000000000000000..bdfb2d8721383bceb9845a9decd831057ba9dfa7
--- /dev/null
+++ b/gcc/testsuite/gm2/extensions/fail/arith1.mod
@@ -0,0 +1,36 @@
+MODULE arith1 ;
+
+IMPORT SYSTEM ;
+FROM libc IMPORT exit, printf ;
+FROM NumberIO IMPORT WriteCard ;
+FROM StrIO IMPORT WriteLn ;
+
+
+PROCEDURE assert (computed, result: CARDINAL; message: ARRAY OF CHAR) ;
+BEGIN
+ IF computed # result
+ THEN
+ printf (message, computed, result) ;
+ exit (1)
+ END
+END assert ;
+
+
+PROCEDURE testCardinal ;
+VAR
+ c64: SYSTEM.CARDINAL64 ;
+ c32: SYSTEM.CARDINAL32 ;
+ c16: SYSTEM.CARDINAL32 ;
+ c8 : SYSTEM.CARDINAL8 ;
+BEGIN
+ c8 := 7 ;
+ c16 := 7000H ;
+ c32 := 7 ;
+ c64 := 0000000100000000H ;
+ c16 := c16 + c8 ;
+END testCardinal ;
+
+
+BEGIN
+ testCardinal
+END arith1.
diff --git a/gcc/testsuite/gm2/extensions/fail/arith2.mod b/gcc/testsuite/gm2/extensions/fail/arith2.mod
new file mode 100644
index 0000000000000000000000000000000000000000..fc6cb261f82bb1b769e12609da1976318e884600
--- /dev/null
+++ b/gcc/testsuite/gm2/extensions/fail/arith2.mod
@@ -0,0 +1,36 @@
+MODULE arith2 ;
+
+IMPORT SYSTEM ;
+FROM libc IMPORT exit, printf ;
+FROM NumberIO IMPORT WriteCard ;
+FROM StrIO IMPORT WriteLn ;
+
+
+PROCEDURE assert (computed, result: CARDINAL; message: ARRAY OF CHAR) ;
+BEGIN
+ IF computed # result
+ THEN
+ printf (message, computed, result) ;
+ exit (1)
+ END
+END assert ;
+
+
+PROCEDURE testCardinal ;
+VAR
+ c64: SYSTEM.CARDINAL64 ;
+ c32: SYSTEM.CARDINAL32 ;
+ c16: SYSTEM.CARDINAL32 ;
+ c8 : SYSTEM.CARDINAL8 ;
+BEGIN
+ c8 := 7 ;
+ c16 := 7000H ;
+ c32 := 7 ;
+ c64 := 0000000100000000H ;
+ c64 := c64 + c8
+END testCardinal ;
+
+
+BEGIN
+ testCardinal
+END arith2.
diff --git a/gcc/testsuite/gm2/extensions/fail/arith3.mod b/gcc/testsuite/gm2/extensions/fail/arith3.mod
new file mode 100644
index 0000000000000000000000000000000000000000..6d348812498919a999e22f20b6dec1b2f85e722e
--- /dev/null
+++ b/gcc/testsuite/gm2/extensions/fail/arith3.mod
@@ -0,0 +1,36 @@
+MODULE arith3 ;
+
+IMPORT SYSTEM ;
+FROM libc IMPORT exit, printf ;
+FROM NumberIO IMPORT WriteCard ;
+FROM StrIO IMPORT WriteLn ;
+
+
+PROCEDURE assert (computed, result: CARDINAL; message: ARRAY OF CHAR) ;
+BEGIN
+ IF computed # result
+ THEN
+ printf (message, computed, result) ;
+ exit (1)
+ END
+END assert ;
+
+
+PROCEDURE testCardinal ;
+VAR
+ c64: SYSTEM.CARDINAL64 ;
+ c32: SYSTEM.CARDINAL32 ;
+ c16: SYSTEM.CARDINAL32 ;
+ c8 : SYSTEM.CARDINAL8 ;
+BEGIN
+ c8 := 7 ;
+ c16 := 7000H ;
+ c32 := 7 ;
+ c64 := 0000000100000000H ;
+ c64 := c32 + c64
+END testCardinal ;
+
+
+BEGIN
+ testCardinal
+END arith3.
diff --git a/gcc/testsuite/gm2/extensions/fail/arith4.mod b/gcc/testsuite/gm2/extensions/fail/arith4.mod
new file mode 100644
index 0000000000000000000000000000000000000000..82494529dfca0d16569acbc101579d722dd6fdae
--- /dev/null
+++ b/gcc/testsuite/gm2/extensions/fail/arith4.mod
@@ -0,0 +1,36 @@
+MODULE arith4 ;
+
+IMPORT SYSTEM ;
+FROM libc IMPORT exit, printf ;
+FROM NumberIO IMPORT WriteCard ;
+FROM StrIO IMPORT WriteLn ;
+
+
+PROCEDURE assert (computed, result: CARDINAL; message: ARRAY OF CHAR) ;
+BEGIN
+ IF computed # result
+ THEN
+ printf (message, computed, result) ;
+ exit (1)
+ END
+END assert ;
+
+
+PROCEDURE testCardinal ;
+VAR
+ c64: SYSTEM.CARDINAL64 ;
+ c32: SYSTEM.CARDINAL32 ;
+ c16: SYSTEM.CARDINAL32 ;
+ c8 : SYSTEM.CARDINAL8 ;
+BEGIN
+ c8 := 7 ;
+ c16 := 7000H ;
+ c32 := 7 ;
+ c64 := 0000000100000000H ;
+ c64 := 16 * c64 + c32; (* Should fail here. *)
+END testCardinal ;
+
+
+BEGIN
+ testCardinal
+END arith4.
diff --git a/gcc/testsuite/gm2/extensions/fail/arithpromote.mod b/gcc/testsuite/gm2/extensions/fail/arithpromote.mod
new file mode 100644
index 0000000000000000000000000000000000000000..59738cbfb4701544266a83f3c883355fb1f31a59
--- /dev/null
+++ b/gcc/testsuite/gm2/extensions/fail/arithpromote.mod
@@ -0,0 +1,55 @@
+MODULE arithpromote ;
+
+IMPORT SYSTEM ;
+FROM libc IMPORT exit, printf ;
+FROM NumberIO IMPORT WriteCard ;
+FROM StrIO IMPORT WriteLn ;
+
+
+PROCEDURE assert (computed, result: CARDINAL; message: ARRAY OF CHAR) ;
+BEGIN
+ IF computed # result
+ THEN
+ printf (message, computed, result) ;
+ exit (1)
+ END
+END assert ;
+
+
+PROCEDURE testCardinal ;
+VAR
+ c64: SYSTEM.CARDINAL64 ;
+ c32: SYSTEM.CARDINAL32 ;
+ c16: SYSTEM.CARDINAL32 ;
+ c8 : SYSTEM.CARDINAL8 ;
+BEGIN
+ c8 := 7 ;
+ c16 := 7000H ;
+ c32 := 7 ;
+ c64 := 0000000100000000H ;
+(*
+ assert (c16 + c8, 7007H, "addition between CARDINAL16 and CARDINAL8 fails: %d # %d\n") ;
+ c64 := 0000000100000000H ;
+*)
+(*
+ IF c64 + c8 # 0000000100000007H
+ THEN
+ printf ("failure when adding 0000000100000000H + 7\n");
+ exit (1)
+ END
+*)
+(*
+ IF c64 + c32 # 0000000100000007H
+ THEN
+ printf ("failure when adding 0000000100000000H + 7\n");
+ exit (1)
+ END
+*)
+ c64 := 16 * c64 + c32; (* Should fail here. *)
+ c64 := c32 + c64 ;
+END testCardinal ;
+
+
+BEGIN
+ testCardinal
+END arithpromote.
diff --git a/gcc/testsuite/gm2/extensions/fail/extensions-fail.exp b/gcc/testsuite/gm2/extensions/fail/extensions-fail.exp
new file mode 100644
index 0000000000000000000000000000000000000000..3839a0a3179bc5a75366497de4cad789a6f26060
--- /dev/null
+++ b/gcc/testsuite/gm2/extensions/fail/extensions-fail.exp
@@ -0,0 +1,36 @@
+# Copyright (C) 2003-2024 Free Software Foundation, Inc.
+
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with GCC; see the file COPYING3. If not see
+# <http://www.gnu.org/licenses/>.
+
+# This file was written by Gaius Mulley (gaius.mulley@southwales.ac.uk)
+# for GNU Modula-2.
+
+if $tracelevel then {
+ strace $tracelevel
+}
+
+# load support procs
+load_lib gm2-torture.exp
+
+gm2_init_pim "${srcdir}/gm2/extensions/fail"
+
+foreach testcase [lsort [glob -nocomplain $srcdir/$subdir/*.mod]] {
+ # If we're only testing specific files and this isn't one of them, skip it.
+ if ![runtest_file_p $runtests $testcase] then {
+ continue
+ }
+
+ gm2-torture-fail $testcase
+}
diff --git a/gcc/testsuite/gm2/linking/fail/badimp.def b/gcc/testsuite/gm2/linking/fail/badimp.def
new file mode 100644
index 0000000000000000000000000000000000000000..1b31f0b4284bd0b2cc9da38b8dac35f5726e8cbd
--- /dev/null
+++ b/gcc/testsuite/gm2/linking/fail/badimp.def
@@ -0,0 +1,4 @@
+DEFINITION MODULE badimp ;
+
+
+END badimp.
diff --git a/gcc/testsuite/gm2/linking/fail/badimp.mod b/gcc/testsuite/gm2/linking/fail/badimp.mod
new file mode 100644
index 0000000000000000000000000000000000000000..02da928b1802e8b5a3883e9e45c986ddcf2dd725
--- /dev/null
+++ b/gcc/testsuite/gm2/linking/fail/badimp.mod
@@ -0,0 +1,8 @@
+(* { dg-skip-if "" { *-*-* } } *)
+
+MODULE badimp ;
+
+(* User forgot the IMPLEMENTATION keyword prior to MODULE. *)
+
+BEGIN
+END badimp.
diff --git a/gcc/testsuite/gm2/linking/fail/linking-fail.exp b/gcc/testsuite/gm2/linking/fail/linking-fail.exp
new file mode 100644
index 0000000000000000000000000000000000000000..95e95d6c10a2d05ff6631ea730ebae8e9898dced
--- /dev/null
+++ b/gcc/testsuite/gm2/linking/fail/linking-fail.exp
@@ -0,0 +1,38 @@
+# Copyright (C) 2024 Free Software Foundation, Inc.
+
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with GCC; see the file COPYING3. If not see
+# <http://www.gnu.org/licenses/>.
+
+# This file was written by Gaius Mulley (gaius.mulley@southwales.ac.uk)
+# for GNU Modula-2.
+
+if $tracelevel then {
+ strace $tracelevel
+}
+
+# load support procs
+load_lib gm2-torture.exp
+
+gm2_init_pim "${srcdir}/gm2/linking/fail" -fscaffold-main
+
+foreach testcase [lsort [glob -nocomplain $srcdir/$subdir/*.mod]] {
+ # If we're only testing specific files and this isn't one of them, skip it.
+ if ![runtest_file_p $runtests $testcase] then {
+ continue
+ }
+
+ if { $testcase != "$srcdir/$subdir/badimp.mod" } {
+ gm2-torture-fail $testcase
+ }
+}
diff --git a/gcc/testsuite/gm2/linking/fail/testbadimp.mod b/gcc/testsuite/gm2/linking/fail/testbadimp.mod
new file mode 100644
index 0000000000000000000000000000000000000000..cdea4fc05376f080d32000a674412feccf61bda4
--- /dev/null
+++ b/gcc/testsuite/gm2/linking/fail/testbadimp.mod
@@ -0,0 +1,6 @@
+MODULE testbadimp ;
+
+IMPORT badimp ;
+
+BEGIN
+END testbadimp.