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,
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 ) |
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.
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))
GetPriority, GetNeedSavePriority,
PutConstString,
PutConst, PutConstSet, PutConstructor,
- GetSType,
+ GetSType, GetTypeMode,
HasVarParameters,
NulSym ;
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
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) ;
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.
*)
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) ;
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)))
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
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
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
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
*)
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
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)))
ForeachFieldEnumerationDo, ForeachLocalSymDo,
GetExported, PutImported, GetSym, GetLibName,
+ GetTypeMode,
IsUnused,
NulSym ;
CONST
DebugStackOn = TRUE ;
DebugVarients = FALSE ;
- BreakAtQuad = 53 ;
+ BreakAtQuad = 189 ;
DebugTokPos = FALSE ;
TYPE
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 ;
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) ;
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
combinedtok,
functok,
optok : CARDINAL ;
+ opa,
ReturnVar,
NoOfParam,
OperandSym,
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,
ReturnVar,
NoOfParam,
OperandSym,
+ opa,
VarSym : CARDINAL ;
BEGIN
PopT (NoOfParam) ;
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,
TempVar,
NoOfParam,
OperandSym,
+ opa,
VarSym : CARDINAL ;
BEGIN
PopT (NoOfParam) ;
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 )
*)
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,
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) ;
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) ;
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:
PtrToBase,
Base,
Dim, rw,
- ti, tj, tk : CARDINAL ;
+ ti, tj, tk,
+ tka : CARDINAL ;
BEGIN
DisplayStack ;
Sym := OperandT (2) ;
*)
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
AddSymToModuleScope,
GetType, GetLType, GetSType, GetDType,
SkipType, SkipTypeAndSubrange,
- GetLowestType,
+ GetLowestType, GetTypeMode,
GetSym, GetLocalSym, GetDeclareSym, GetRecord,
FromModuleGetSym,
GetOAFamily,
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.
UnboundedAddressName = "_m2_contents" ;
UnboundedHighName = "_m2_high_%d" ;
+ BreakSym = 5293 ;
+
TYPE
ConstLitPoolEntry = POINTER TO RECORD
sym : CARDINAL ;
END FinalSymbol ;
+(*
+ stop - a debugger convenience hook.
+*)
+
+PROCEDURE stop ;
+END stop ;
+
+
(*
NewSym - Sets Sym to a new symbol index.
*)
SymbolType := DummySym
END ;
PutIndice(Symbols, sym, pSym) ;
+ IF sym = BreakSym
+ THEN
+ stop
+ END ;
INC(FreeSymbol)
END NewSym ;
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.
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 ;
--- /dev/null
+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.
--- /dev/null
+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.
--- /dev/null
+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.
--- /dev/null
+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.
--- /dev/null
+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.
--- /dev/null
+# 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
+}
--- /dev/null
+DEFINITION MODULE badimp ;
+
+
+END badimp.
--- /dev/null
+(* { dg-skip-if "" { *-*-* } } *)
+
+MODULE badimp ;
+
+(* User forgot the IMPLEMENTATION keyword prior to MODULE. *)
+
+BEGIN
+END badimp.
--- /dev/null
+# 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
+ }
+}
--- /dev/null
+MODULE testbadimp ;
+
+IMPORT badimp ;
+
+BEGIN
+END testbadimp.
projects / thirdparty / gcc.git / commitdiff
