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

PR-108551 gcc/m2/gm2-libs-pim/Termbase.mod:128:1 error end of non-void

Browse source 
cc1gm2 generates an error: control reaches end of non-void function when
compiling Termbase.mod if -Werror=return-type is present.

../gcc/m2/gm2-libs-pim/Termbase.mod: In function 'Termbase_KeyPressed':
../gcc/m2/gm2-libs-pim/Termbase.mod:128:1: error: control reaches end
	of non-void function [-Werror=return-type]
   128 | END KeyPressed ;
       | ^~~

This occurs as cc1gm2 does skips over the <* noreturn *> attribute.  This
patch records the <* noreturn *> attribute in the m2 symbol table and
later on sets TREE_THIS_VOLATILE when creating the function decl.
The patch also contains a fix for the main scaffold which also omitted
a return 0 after the exception handler code.

gcc/m2/ChangeLog:

	* gm2-compiler/M2GCCDeclare.mod: Import IsProcedureNoReturn.
	(DeclareProcedureToGccWholeProgram): New variable declared and set
	returnType.  Pass returnType to BuildEndFunctionDeclaration.
	Extra parameter IsProcedureNoReturn passed to
	BuildEndFunctionDeclaration.
	* gm2-compiler/M2Quads.mod (BuildM2MainFunction): Correct
	scaffold comment and add extra return 0.
	* gm2-compiler/P2Build.bnf: Import BuildNoReturnAttribute.
	(ProcedureHeading): Process EndBuildFormalParameters before
	parsing AttributeNoReturn.
	(DefProcedureHeading): Process EndBuildFormalParameters before
	parsing AttributeNoReturn.
	(AttributeNoReturn): Call BuildNoReturnAttribute.
	* gm2-compiler/P2SymBuild.def (BuildNoReturnAttribute): New
	procedure.
	* gm2-compiler/P2SymBuild.mod (BuildNoReturnAttribute): New
	procedure.
	* gm2-compiler/SymbolTable.def (PutProcedureInline): Corrected
	comment.
	(PutProcedureNoReturn): New procedure.
	(IsProcedureNoReturn): New procedure function.
	* gm2-compiler/SymbolTable.mod (SymProcedure): IsNoReturn
	new field.
	(MakeProcedure): Initialize IsNoReturn to FALSE.
	(PutProcedureNoReturn): New procedure.
	(IsProcedureNoReturn): New procedure function.
	* gm2-gcc/m2decl.cc (m2decl_BuildEndFunctionDeclaration):
	Add extra parameter isnoreturn.  Set TREE_THIS_VOLATILE
	to isnoreturn.
	* gm2-gcc/m2decl.def (BuildEndFunctionDeclaration): Add
	extra parameter isnoreturn.
	* gm2-gcc/m2decl.h (m2decl_BuildEndFunctionDeclaration): Add
	extra parameter isnoreturn.
	* gm2-gcc/m2except.cc (m2except_InitExceptions): Change all
	function decl to pass an extra parameter isnoreturn.

gcc/testsuite/ChangeLog:

	* gm2/warnings/returntype/fail/badreturn.mod: New test.
	* gm2/warnings/returntype/fail/warnings-returntype-fail.exp:
	New test.
	* gm2/warnings/returntype/pass/Termbase.mod: New test.
	* gm2/warnings/returntype/pass/goodreturn.mod: New test.
	* gm2/warnings/returntype/pass/keypressedsimple.mod: New test.
	* gm2/warnings/returntype/pass/warnings-returntype-pass.exp:
	New test.

Signed-off-by: Gaius Mulley <gaiusmod2@gmail.com>
This commit is contained in:
Gaius Mulley 2023-01-26 21:43:22 +00:00
parent 67bcd1c5ed
commit 94673a121c
17 changed files with 463 additions and 30 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

27
gcc/m2/gm2-compiler/M2GCCDeclare.mod
View file

@ -105,7 +105,7 @@ FROM SymbolTable IMPORT NulSym,
IsAModula2Type, UsesVarArgs,
GetSymName, GetParent,
GetDeclaredMod, GetVarBackEndType,
GetProcedureBeginEnd,
GetProcedureBeginEnd, IsProcedureNoReturn,
GetString, GetStringLength, IsConstString,
IsConstStringM2, IsConstStringC, IsConstStringM2nul, IsConstStringCnul,
GetAlignment, IsDeclaredPacked, PutDeclaredPacked,
@ -2347,6 +2347,7 @@ END IsExternalToWholeProgram ;
PROCEDURE DeclareProcedureToGccWholeProgram (Sym: CARDINAL) ;
VAR
returnType,
GccParam : Tree ;
scope,
Son,
@ -2391,20 +2392,17 @@ BEGIN
PushBinding(scope) ;
IF GetSType(Sym)=NulSym
THEN
PreAddModGcc(Sym, BuildEndFunctionDeclaration(begin, end,
KeyToCharStar(GetFullSymName(Sym)),
NIL,
IsExternalToWholeProgram(Sym),
IsProcedureGccNested(Sym),
IsExported(GetModuleWhereDeclared(Sym), Sym)))
returnType := NIL
ELSE
PreAddModGcc(Sym, BuildEndFunctionDeclaration(begin, end,
KeyToCharStar(GetFullSymName(Sym)),
Mod2Gcc(GetSType(Sym)),
IsExternalToWholeProgram(Sym),
IsProcedureGccNested(Sym),
IsExported(GetModuleWhereDeclared(Sym), Sym)))
returnType := Mod2Gcc(GetSType(Sym))
END ;
PreAddModGcc(Sym, BuildEndFunctionDeclaration(begin, end,
KeyToCharStar(GetFullSymName(Sym)),
returnType,
IsExternalToWholeProgram(Sym),
IsProcedureGccNested(Sym),
IsExported(GetModuleWhereDeclared(Sym), Sym),
IsProcedureNoReturn(Sym))) ;
PopBinding(scope) ;
WatchRemoveList(Sym, todolist) ;
WatchIncludeList(Sym, fullydeclared)
@ -2481,7 +2479,8 @@ BEGIN
IsExternal (Sym), (* Extern relative to the main module. *)
IsProcedureGccNested (Sym),
(* Exported from the module where it was declared. *)
IsExported (GetModuleWhereDeclared (Sym), Sym) OR IsExtern (Sym))) ;
IsExported (GetModuleWhereDeclared (Sym), Sym) OR IsExtern (Sym),
IsProcedureNoReturn(Sym))) ;
PopBinding(scope) ;
WatchRemoveList(Sym, todolist) ;
WatchIncludeList(Sym, fullydeclared)

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

@ -2469,6 +2469,7 @@ BEGIN
}
catch (...) {
RTExceptions_DefaultErrorCatch ();
return 0;
}
}
*)
@ -2492,10 +2493,11 @@ BEGIN
PushTtok (RequestSym (tokno, MakeKey ("envp")), tokno) ;
PushT (3) ;
BuildProcedureCall (tokno) ;
PushZero (tokno, Integer) ;
BuildReturn (tokno) ;
BuildExcept (tokno) ;
PushZero (tokno, Integer) ;
BuildReturn (tokno) ;
EndScope ;
BuildProcedureEnd ;
PopN (1)

11
gcc/m2/gm2-compiler/P2Build.bnf
View file

@ -97,6 +97,7 @@ FROM P2SymBuild IMPORT P2StartBuildProgramModule,
StartBuildProcedure,
EndBuildProcedure,
BuildFunction, BuildOptFunction,
BuildNoReturnAttribute,
BuildPointerType,
BuildRecord, BuildFieldRecord,
@ -1025,8 +1026,8 @@ ProcedureHeading := "PROCEDURE" % M2E
% StartBuildProcedure %
% Assert(IsProcedure(OperandT(1))) %
% StartBuildFormalParameters %
[ FormalParameters ] AttributeNoReturn
% EndBuildFormalParameters %
[ FormalParameters ] % EndBuildFormalParameters %
AttributeNoReturn
% BuildProcedureHeading %
)
=:
@ -1039,8 +1040,8 @@ DefProcedureHeading := "PROCEDURE" % M2E
% StartBuildProcedure %
% Assert(IsProcedure(OperandT(1))) %
% StartBuildFormalParameters %
[ DefFormalParameters ] AttributeNoReturn
% EndBuildFormalParameters %
[ DefFormalParameters ] % EndBuildFormalParameters %
AttributeNoReturn
% BuildProcedureHeading %
) % M2Error.LeaveErrorScope %
=:
@ -1048,6 +1049,8 @@ DefProcedureHeading := "PROCEDURE" % M2E
AttributeNoReturn := [ "<*" % PushAutoOn %
Ident % PopAuto %
% checkReturnAttribute %
% Assert(IsProcedure(OperandT(1))) %
% BuildNoReturnAttribute (OperandT(1)) %
"*>" ] =:
AttributeUnused := [ "<*" % PushAutoOn %

7
gcc/m2/gm2-compiler/P2SymBuild.def
View file

@ -863,6 +863,13 @@ PROCEDURE StartBuildProcedure ;
PROCEDURE EndBuildProcedure ;
(*
BuildNoReturnAttribute - provide an interface to the symbol table module.
*)
PROCEDURE BuildNoReturnAttribute (procedureSym: CARDINAL) ;
(*
BuildPointerType - builds a pointer type.
The Stack:

12
gcc/m2/gm2-compiler/P2SymBuild.mod
View file

@ -108,6 +108,7 @@ FROM SymbolTable IMPORT NulSym,
ParametersDefinedInDefinition,
ParametersDefinedInImplementation,
ProcedureParametersDefined,
PutProcedureNoReturn,
CheckForUnImplementedExports,
CheckForUndeclaredExports,
IsHiddenTypeDeclared,
@ -2098,6 +2099,17 @@ BEGIN
END BuildOptFunction ;
(*
BuildNoReturnAttribute - provide an interface to the symbol table module.
*)
PROCEDURE BuildNoReturnAttribute (procedureSym: CARDINAL) ;
BEGIN
Assert (IsProcedure (procedureSym)) ;
PutProcedureNoReturn (procedureSym, TRUE)
END BuildNoReturnAttribute ;
(*
BuildPointerType - builds a pointer type.
The Stack:

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

@ -191,6 +191,7 @@ EXPORT QUALIFIED NulSym,
PutProcedureEndQuad,
PutProcedureScopeQuad,
PutProcedureReachable,
PutProcedureNoReturn, IsProcedureNoReturn,
PutReadQuad, RemoveReadQuad,
PutWriteQuad, RemoveWriteQuad,
PutGnuAsm, PutGnuAsmOutput, PutGnuAsmInput, PutGnuAsmTrash,
@ -1274,7 +1275,7 @@ PROCEDURE PutProcedureInline (Sym: CARDINAL) ;
(*
IsProcedureBuiltin - returns TRUE if this procedure was declared as inlined.
IsProcedureInline - returns TRUE if this procedure was declared as inlined.
*)
PROCEDURE IsProcedureInline (Sym: CARDINAL) : BOOLEAN ;
@ -1636,6 +1637,21 @@ PROCEDURE PutProcedureReachable (Sym: CARDINAL) ;
PROCEDURE IsProcedureReachable (Sym: CARDINAL) : BOOLEAN ;
(*
PutProcedureNoReturn - places value into the no return attribute
field of procedure sym.
*)
PROCEDURE PutProcedureNoReturn (Sym: CARDINAL; value: BOOLEAN) ;
(*
IsProcedureNoReturn - returns TRUE if this procedure never returns.
*)
PROCEDURE IsProcedureNoReturn (Sym: CARDINAL) : BOOLEAN ;
(*
PutModuleStartQuad - Places QuadNumber into the Module symbol, Sym.
QuadNumber is the start quad of Module,

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

@ -360,6 +360,7 @@ TYPE
IsBuiltin : BOOLEAN ; (* Was it declared __BUILTIN__ ? *)
BuiltinName : Name ; (* name of equivalent builtin *)
IsInline : BOOLEAN ; (* Was it declared __INLINE__ ? *)
IsNoReturn : BOOLEAN ; (* Attribute noreturn ? *)
ReturnOptional: BOOLEAN ; (* Is the return value optional? *)
IsExtern : BOOLEAN ; (* Make this procedure extern. *)
IsPublic : BOOLEAN ; (* Make this procedure visible. *)
@ -3775,6 +3776,7 @@ BEGIN
IsBuiltin := FALSE ; (* Was it declared __BUILTIN__ ? *)
BuiltinName := NulName ; (* name of equivalent builtin *)
IsInline := FALSE ; (* Was is declared __INLINE__ ? *)
IsNoReturn := FALSE ; (* Declared attribute noreturn ? *)
ReturnOptional := FALSE ; (* Is the return value optional? *)
IsExtern := FALSE ; (* Make this procedure external. *)
IsPublic := FALSE ; (* Make this procedure visible. *)
@ -3824,6 +3826,49 @@ BEGIN
END MakeProcedure ;
(*
PutProcedureNoReturn - places value into the no return attribute
field of procedure sym.
*)
PROCEDURE PutProcedureNoReturn (Sym: CARDINAL; value: BOOLEAN) ;
VAR
pSym: PtrToSymbol ;
BEGIN
pSym := GetPsym (Sym) ;
WITH pSym^ DO
CASE SymbolType OF
ProcedureSym: Procedure.IsNoReturn := value
ELSE
InternalError ('expecting ProcedureSym symbol')
END
END
END PutProcedureNoReturn ;
(*
IsProcedureNoReturn - returns TRUE if this procedure never returns.
*)
PROCEDURE IsProcedureNoReturn (Sym: CARDINAL) : BOOLEAN ;
VAR
pSym: PtrToSymbol ;
BEGIN
pSym := GetPsym (Sym) ;
WITH pSym^ DO
CASE SymbolType OF
ProcedureSym: RETURN Procedure.IsNoReturn
ELSE
InternalError ('expecting ProcedureSym symbol')
END
END
END IsProcedureNoReturn ;
(*
PutMonoName - changes the IsMonoName boolean inside the procedure.
*)

3
gcc/m2/gm2-gcc/m2decl.cc
View file

@ -211,7 +211,7 @@ tree
m2decl_BuildEndFunctionDeclaration (location_t location_begin,
location_t location_end, const char *name,
tree returntype, int isexternal,
int isnested, int ispublic)
int isnested, int ispublic, int isnoreturn)
{
tree fntype;
tree fndecl;
@ -244,6 +244,7 @@ m2decl_BuildEndFunctionDeclaration (location_t location_begin,
= build_decl (location_end, RESULT_DECL, NULL_TREE, returntype);
DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
TREE_TYPE (fndecl) = fntype;
TREE_THIS_VOLATILE (fndecl) = isnoreturn;
DECL_SOURCE_LOCATION (fndecl) = location_begin;

3
gcc/m2/gm2-gcc/m2decl.def
View file

@ -149,7 +149,8 @@ PROCEDURE BuildStartFunctionDeclaration (uses_varargs: BOOLEAN) ;
PROCEDURE BuildEndFunctionDeclaration (location_begin, location_end: location_t;
name: ADDRESS; returntype: Tree;
isexternal, isnested, ispublic: BOOLEAN) : Tree ;
isexternal, isnested, ispublic,
isnoreturn: BOOLEAN) : Tree ;
(*

3
gcc/m2/gm2-gcc/m2decl.h
View file

@ -58,7 +58,8 @@ EXTERN void m2decl_RememberVariables (tree l);
EXTERN tree m2decl_BuildEndFunctionDeclaration (
location_t location_begin, location_t location_end, const char *name,
tree returntype, int isexternal, int isnested, int ispublic);
tree returntype, int isexternal, int isnested, int ispublic,
int isnoreturn);
EXTERN void m2decl_BuildStartFunctionDeclaration (int uses_varargs);
EXTERN tree m2decl_BuildParameterDeclaration (location_t location, char *name,
tree type, int isreference);

17
gcc/m2/gm2-gcc/m2except.cc
View file

@ -103,18 +103,19 @@ m2except_InitExceptions (location_t location)
m2decl_BuildStartFunctionDeclaration (FALSE);
fn_rethrow_tree = m2decl_BuildEndFunctionDeclaration (
location, location, "__cxa_rethrow", void_type_node, TRUE, FALSE, TRUE);
location, location, "__cxa_rethrow", void_type_node, TRUE, FALSE,
TRUE, FALSE);
TREE_NOTHROW (fn_rethrow_tree) = 0;
m2decl_BuildStartFunctionDeclaration (FALSE);
m2decl_BuildParameterDeclaration (location, NULL, ptr_type_node, FALSE);
fn_begin_catch_tree = m2decl_BuildEndFunctionDeclaration (
location, location, "__cxa_begin_catch", ptr_type_node, TRUE, FALSE,
TRUE);
TRUE, FALSE);
m2decl_BuildStartFunctionDeclaration (FALSE);
fn_end_catch_tree = m2decl_BuildEndFunctionDeclaration (
location, location, "__cxa_end_catch", void_type_node, TRUE, FALSE,
TRUE);
TRUE, FALSE);
/* This can throw if the destructor for the exception throws. */
TREE_NOTHROW (fn_end_catch_tree) = 0;
@ -130,26 +131,28 @@ m2except_InitExceptions (location_t location)
m2decl_BuildParameterDeclaration (location, NULL, ptr_type_node, FALSE);
m2decl_BuildParameterDeclaration (location, NULL, ptr_type_node, FALSE);
fn_throw_tree = m2decl_BuildEndFunctionDeclaration (
location, location, "__cxa_throw", void_type_node, TRUE, FALSE, TRUE);
location, location, "__cxa_throw", void_type_node, TRUE, FALSE, TRUE,
FALSE);
/* Declare void __cxa_rethrow (void). */
m2decl_BuildStartFunctionDeclaration (FALSE);
fn_rethrow_tree = m2decl_BuildEndFunctionDeclaration (
location, location, "__cxa_rethrow", void_type_node, TRUE, FALSE, TRUE);
location, location, "__cxa_rethrow", void_type_node, TRUE, FALSE, TRUE,
FALSE);
/* Declare void *__cxa_allocate_exception (size_t). */
m2decl_BuildStartFunctionDeclaration (FALSE);
m2decl_BuildParameterDeclaration (location, NULL, size_type_node, FALSE);
fn_allocate_exception_tree = m2decl_BuildEndFunctionDeclaration (
location, location, "__cxa_allocate_exception", ptr_type_node, TRUE,
FALSE, TRUE);
FALSE, TRUE, FALSE);
/* Declare void *__cxa_free_exception (void *). */
m2decl_BuildStartFunctionDeclaration (FALSE);
m2decl_BuildParameterDeclaration (location, NULL, ptr_type_node, FALSE);
fn_free_exception_tree = m2decl_BuildEndFunctionDeclaration (
location, location, "__cxa_free_exception", ptr_type_node, TRUE, FALSE,
TRUE);
TRUE, FALSE);
/* Define integer type exception type which will match C++ int type
in the C++ runtime library. */

11
gcc/testsuite/gm2/warnings/returntype/fail/badreturn.mod Normal file
View file

@ -0,0 +1,11 @@
MODULE badreturn ;
PROCEDURE X (VAR Y : BOOLEAN) : BOOLEAN;
BEGIN
IF Y
THEN
RETURN FALSE
END
END X ;
END badreturn.

40
gcc/testsuite/gm2/warnings/returntype/fail/warnings-returntype-fail.exp Normal file
View file

@ -0,0 +1,40 @@
# Expect driver script for GCC Regression Tests
# Copyright (C) 2003-2023 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/warnings/returntype/fail"
global TORTURE_OPTIONS
set TORTURE_OPTIONS { { -O0 -g -Werror=return-type } }
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
}

220
gcc/testsuite/gm2/warnings/returntype/pass/Termbase.mod Normal file
View file

@ -0,0 +1,220 @@
(* Termbase.mod provides GNU Modula-2 with a PIM 234 compatible Termbase.
Copyright (C) 2004-2023 Free Software Foundation, Inc.
Contributed by Gaius Mulley <gaius.mulley@southwales.ac.uk>.
This file is part of GNU Modula-2.
GNU Modula-2 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, or (at your option)
any later version.
GNU Modula-2 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.
Under Section 7 of GPL version 3, you are granted additional
permissions described in the GCC Runtime Library Exception, version
3.1, as published by the Free Software Foundation.
You should have received a copy of the GNU General Public License and
a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
<http://www.gnu.org/licenses/>. *)
IMPLEMENTATION MODULE Termbase ;
FROM Storage IMPORT ALLOCATE, DEALLOCATE ;
FROM M2RTS IMPORT Halt ;
IMPORT Display, Keyboard ;
TYPE
ReadMethods = POINTER TO RECORD
r : ReadProcedure ;
s : StatusProcedure ;
next: ReadMethods ;
END ;
WriteMethod = POINTER TO RECORD
w : WriteProcedure ;
next: WriteMethod ;
END ;
VAR
rStack: ReadMethods ;
wStack: WriteMethod ;
(*
AssignRead - assigns a read procedure and status procedure for terminal
input. Done is set to TRUE if successful. Subsequent
Read and KeyPressed calls are mapped onto the user supplied
procedures. The previous read and status procedures are
uncovered and reused after UnAssignRead is called.
*)
PROCEDURE AssignRead (rp: ReadProcedure; sp: StatusProcedure;
VAR Done: BOOLEAN) ;
VAR
t: ReadMethods ;
BEGIN
t := rStack ;
NEW(rStack) ;
IF rStack=NIL
THEN
Done := FALSE
ELSE
WITH rStack^ DO
r := rp ;
s := sp ;
next := t
END ;
Done := TRUE
END
END AssignRead ;
(*
UnAssignRead - undo the last call to AssignRead and set Done to TRUE
on success.
*)
PROCEDURE UnAssignRead (VAR Done: BOOLEAN) ;
VAR
t: ReadMethods ;
BEGIN
IF rStack=NIL
THEN
Done := FALSE
ELSE
Done := TRUE
END ;
t := rStack ;
rStack := rStack^.next ;
DISPOSE(t)
END UnAssignRead ;
(*
Read - reads a single character using the currently active read
procedure.
*)
PROCEDURE Read (VAR ch: CHAR) ;
BEGIN
IF rStack=NIL
THEN
Halt(__FILE__, __LINE__, __FUNCTION__, 'no active read procedure')
ELSE
rStack^.r(ch)
END
END Read ;
(*
KeyPressed - returns TRUE if a character is available to be read.
*)
PROCEDURE KeyPressed () : BOOLEAN ;
BEGIN
IF rStack=NIL
THEN
Halt(__FILE__, __LINE__, __FUNCTION__, 'no active status procedure')
ELSE
RETURN( rStack^.s() )
END
END KeyPressed ;
(*
AssignWrite - assigns a write procedure for terminal output.
Done is set to TRUE if successful. Subsequent
Write calls are mapped onto the user supplied
procedure. The previous write procedure is
uncovered and reused after UnAssignWrite is called.
*)
PROCEDURE AssignWrite (wp: WriteProcedure; VAR Done: BOOLEAN) ;
VAR
t: WriteMethod ;
BEGIN
t := wStack ;
NEW(wStack) ;
IF wStack=NIL
THEN
Done := FALSE
ELSE
WITH wStack^ DO
w := wp ;
next := t
END ;
Done := TRUE
END
END AssignWrite ;
(*
UnAssignWrite - undo the last call to AssignWrite and set Done to TRUE
on success.
*)
PROCEDURE UnAssignWrite (VAR Done: BOOLEAN) ;
VAR
t: WriteMethod ;
BEGIN
IF wStack=NIL
THEN
Done := FALSE
ELSE
Done := TRUE
END ;
t := wStack ;
wStack := wStack^.next ;
DISPOSE(t)
END UnAssignWrite ;
(*
Write - writes a single character using the currently active write
procedure.
*)
PROCEDURE Write (VAR ch: CHAR) ;
BEGIN
IF wStack=NIL
THEN
Halt(__FILE__, __LINE__, __FUNCTION__, 'no active write procedure')
ELSE
wStack^.w(ch)
END
END Write ;
(*
Init -
*)
PROCEDURE Init ;
VAR
Done: BOOLEAN ;
BEGIN
rStack := NIL ;
wStack := NIL ;
AssignRead(Keyboard.Read, Keyboard.KeyPressed, Done) ;
IF NOT Done
THEN
Halt(__FILE__, __LINE__, __FUNCTION__, 'failed to assign read routines from module Keyboard')
END ;
AssignWrite(Display.Write, Done) ;
IF NOT Done
THEN
Halt(__FILE__, __LINE__, __FUNCTION__, 'failed to assign write routine from module Display')
END
END Init ;
BEGIN
Init
END Termbase.

13
gcc/testsuite/gm2/warnings/returntype/pass/goodreturn.mod Normal file
View file

@ -0,0 +1,13 @@
MODULE goodreturn ;
PROCEDURE X (VAR Y : BOOLEAN) : BOOLEAN;
BEGIN
IF Y
THEN
RETURN FALSE
ELSE
RETURN TRUE
END
END X ;
END goodreturn.

21
gcc/testsuite/gm2/warnings/returntype/pass/keypressedsimple.mod Normal file
View file

@ -0,0 +1,21 @@
MODULE keypressedsimple ;
FROM M2RTS IMPORT Halt ;
FROM Args IMPORT Narg ;
PROCEDURE KeyPressed () : BOOLEAN ;
BEGIN
IF Narg () < 0
THEN
Halt(__FILE__, __LINE__, __FUNCTION__, 'no active status procedure')
ELSE
RETURN FALSE
END
END KeyPressed ;
BEGIN
IF KeyPressed ()
THEN
END
END keypressedsimple.

38
gcc/testsuite/gm2/warnings/returntype/pass/warnings-returntype-pass.exp Normal file
View file

@ -0,0 +1,38 @@
# Copyright (C) 2003-2023 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 (gaiusmod2@gmail.com)
# for GNU Modula-2.
if $tracelevel then {
strace $tracelevel
}
# load support procs
load_lib gm2-torture.exp
set gm2src ${srcdir}/../m2
gm2_init_pim "${srcdir}/gm2/warnings/returntype/pass" -Werror=return-type
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 $testcase
}