FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

PR modula2/113730 Unexpected handling of mixed-precision integer arithmetic

Browse source 
This patch fixes a bug which occurs when an expression is created with
a ZType and an integer or cardinal.  The resulting subexpression is
incorrecly given a ZType which allows compatibility with another
integer/cardinal type.  The solution was to fix the subexpression
type.  In turn this required a minor change to SArgs.mod.

gcc/m2/ChangeLog:

	PR modula2/113730
	* gm2-compiler/M2Base.mod (IsUserType): New procedure function.
	(MixTypes): Use IsUserType instead of IsType before calling MixTypes.
	* gm2-compiler/M2GenGCC.mod (GetTypeMode): Remove and import from
	SymbolTable.
	(CodeBinaryCheck): Replace call to MixTypes with MixTypesBinary.
	(CodeBinary): Replace call to MixTypes with MixTypesBinary.
	(CodeIfLess): Replace MixTypes with ComparisonMixTypes.
	(CodeIfGre): Replace MixTypes with ComparisonMixTypes.
	(CodeIfLessEqu): Replace MixTypes with ComparisonMixTypes.
	(CodeIfGreEqu): Replace MixTypes with ComparisonMixTypes.
	(CodeIfEqu): Replace MixTypes with ComparisonMixTypes.
	(CodeIfNotEqu): Replace MixTypes with ComparisonMixTypes.
	(ComparisonMixTypes): New procedure function.
	* gm2-compiler/M2Quads.mod (BuildEndFor): Replace GenQuadO
	with GenQuadOtok and pass tokenpos for the operands to the AddOp
	and XIndrOp.
	(CheckRangeIncDec): Check etype against NulSym and dtype for a
	pointer and set etype to Address.
	(BuildAddAdrFunction): New variable opa.  Convert operand to an
	address and save result in opa.  Replace GenQuad with GenQuadOtok.
	(BuildSubAdrFunction): New variable opa.  Convert operand to an
	address and save result in opa.  Replace GenQuad with GenQuadOtok.
	(BuildDiffAdrFunction): New variable opa.  Convert operand to an
	address and save result in opa.  Replace GenQuad with GenQuadOtok.
	(calculateMultipicand): Replace GenQuadO with GenQuadOtok.
	(ConvertToAddress): New procedure function.
	(BuildDynamicArray): Convert index to address before adding to
	the base.
	* gm2-compiler/SymbolTable.def (GetTypeMode): New procedure function.
	* gm2-compiler/SymbolTable.mod (GetTypeMode): New procedure
	function implemented (moved from M2GenGCC.mod).
	* gm2-libs/SArgs.mod (GetArg): Replace cast to PtrToChar with ADDRESS.

gcc/testsuite/ChangeLog:

	PR modula2/113730
	* gm2/extensions/fail/arith1.mod: New test.
	* gm2/extensions/fail/arith2.mod: New test.
	* gm2/extensions/fail/arith3.mod: New test.
	* gm2/extensions/fail/arith4.mod: New test.
	* gm2/extensions/fail/arithpromote.mod: New test.
	* gm2/extensions/fail/extensions-fail.exp: New test.
	* gm2/linking/fail/badimp.def: New test.
	* gm2/linking/fail/badimp.mod: New test.
	* gm2/linking/fail/linking-fail.exp: New test.
	* gm2/linking/fail/testbadimp.mod: New test.

Signed-off-by: Gaius Mulley <gaiusmod2@gmail.com>
This commit is contained in:
Gaius Mulley 2024-02-03 00:03:39 +00:00
parent 85094e2aa6
commit 64b0130bb6
16 changed files with 463 additions and 55 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

19
gcc/m2/gm2-compiler/M2Base.mod
View file

@ -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))

92
gcc/m2/gm2-compiler/M2GenGCC.mod
View file

@ -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)))

72
gcc/m2/gm2-compiler/M2Quads.mod
View file

@ -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

10
gcc/m2/gm2-compiler/SymbolTable.def
View file

@ -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.

30
gcc/m2/gm2-compiler/SymbolTable.mod
View file

@ -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.

4
gcc/m2/gm2-libs/SArgs.mod
View file

@ -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 ;

36
gcc/testsuite/gm2/extensions/fail/arith1.mod Normal file
View file

@ -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.

36
gcc/testsuite/gm2/extensions/fail/arith2.mod Normal file
View file

@ -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.

36
gcc/testsuite/gm2/extensions/fail/arith3.mod Normal file
View file

@ -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.

36
gcc/testsuite/gm2/extensions/fail/arith4.mod Normal file
View file

@ -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.

55
gcc/testsuite/gm2/extensions/fail/arithpromote.mod Normal file
View file

@ -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.

36
gcc/testsuite/gm2/extensions/fail/extensions-fail.exp Normal file
View file

@ -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
}

4
gcc/testsuite/gm2/linking/fail/badimp.def Normal file
View file

@ -0,0 +1,4 @@
DEFINITION MODULE badimp ;
END badimp.

8
gcc/testsuite/gm2/linking/fail/badimp.mod Normal file
View file

@ -0,0 +1,8 @@
(* { dg-skip-if "" { *-*-* } } *)
MODULE badimp ;
(* User forgot the IMPLEMENTATION keyword prior to MODULE. *)
BEGIN
END badimp.

38
gcc/testsuite/gm2/linking/fail/linking-fail.exp Normal file
View file

@ -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
}
}

6
gcc/testsuite/gm2/linking/fail/testbadimp.mod Normal file
View file

@ -0,0 +1,6 @@
MODULE testbadimp ;
IMPORT badimp ;
BEGIN
END testbadimp.