aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--gcc/m2/gm2-compiler/M2Base.mod19
-rw-r--r--gcc/m2/gm2-compiler/M2GenGCC.mod92
-rw-r--r--gcc/m2/gm2-compiler/M2Quads.mod72
-rw-r--r--gcc/m2/gm2-compiler/SymbolTable.def10
-rw-r--r--gcc/m2/gm2-compiler/SymbolTable.mod30
-rw-r--r--gcc/m2/gm2-libs/SArgs.mod4
-rw-r--r--gcc/testsuite/gm2/extensions/fail/arith1.mod36
-rw-r--r--gcc/testsuite/gm2/extensions/fail/arith2.mod36
-rw-r--r--gcc/testsuite/gm2/extensions/fail/arith3.mod36
-rw-r--r--gcc/testsuite/gm2/extensions/fail/arith4.mod36
-rw-r--r--gcc/testsuite/gm2/extensions/fail/arithpromote.mod55
-rw-r--r--gcc/testsuite/gm2/extensions/fail/extensions-fail.exp36
-rw-r--r--gcc/testsuite/gm2/linking/fail/badimp.def4
-rw-r--r--gcc/testsuite/gm2/linking/fail/badimp.mod8
-rw-r--r--gcc/testsuite/gm2/linking/fail/linking-fail.exp38
-rw-r--r--gcc/testsuite/gm2/linking/fail/testbadimp.mod6
16 files changed, 463 insertions, 55 deletions
diff --git a/gcc/m2/gm2-compiler/M2Base.mod b/gcc/m2/gm2-compiler/M2Base.mod
index 04a0e4e..b867769 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 ) |
@@ -2005,6 +2006,16 @@ 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.
NearTok is used to identify the source position if a type
@@ -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 92ca39f..25bfbf8 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 ;
@@ -2944,21 +2944,6 @@ 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
type converted if necessary.
@@ -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) ;
@@ -3554,6 +3539,23 @@ 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
@@ -7147,6 +7149,24 @@ 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 a666a4e..a23fa32 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) ;
@@ -11223,6 +11245,29 @@ 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 958591a..6cbc5c2 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,
@@ -1175,6 +1175,14 @@ 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 d939d58..7cef7ee 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 ;
@@ -1015,6 +1017,14 @@ 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 ;
@@ -6603,6 +6617,22 @@ 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 b1996cc..d6cb448 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 0000000..bdfb2d8
--- /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 0000000..fc6cb26
--- /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 0000000..6d34881
--- /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 0000000..8249452
--- /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 0000000..59738cb
--- /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 0000000..3839a0a
--- /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 0000000..1b31f0b
--- /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 0000000..02da928
--- /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 0000000..95e95d6
--- /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 0000000..cdea4fc
--- /dev/null
+++ b/gcc/testsuite/gm2/linking/fail/testbadimp.mod
@@ -0,0 +1,6 @@
+MODULE testbadimp ;
+
+IMPORT badimp ;
+
+BEGIN
+END testbadimp.
generated by cgit v1.1 at 2025-04-28 00:12:41 +0000