diff --git a/gcc/m2/gm2-compiler/M2GCCDeclare.mod b/gcc/m2/gm2-compiler/M2GCCDeclare.mod index 27745988c01..445c039a0c2 100644 --- a/gcc/m2/gm2-compiler/M2GCCDeclare.mod +++ b/gcc/m2/gm2-compiler/M2GCCDeclare.mod @@ -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) diff --git a/gcc/m2/gm2-compiler/M2Quads.mod b/gcc/m2/gm2-compiler/M2Quads.mod index 939758fed7a..3b6ed4531e9 100644 --- a/gcc/m2/gm2-compiler/M2Quads.mod +++ b/gcc/m2/gm2-compiler/M2Quads.mod @@ -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) diff --git a/gcc/m2/gm2-compiler/P2Build.bnf b/gcc/m2/gm2-compiler/P2Build.bnf index ee2497b889d..ea5cfe73a5d 100644 --- a/gcc/m2/gm2-compiler/P2Build.bnf +++ b/gcc/m2/gm2-compiler/P2Build.bnf @@ -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 % diff --git a/gcc/m2/gm2-compiler/P2SymBuild.def b/gcc/m2/gm2-compiler/P2SymBuild.def index d4fc693dd86..b377011c54a 100644 --- a/gcc/m2/gm2-compiler/P2SymBuild.def +++ b/gcc/m2/gm2-compiler/P2SymBuild.def @@ -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: diff --git a/gcc/m2/gm2-compiler/P2SymBuild.mod b/gcc/m2/gm2-compiler/P2SymBuild.mod index cb80ccf2a9a..de56cc46c5c 100644 --- a/gcc/m2/gm2-compiler/P2SymBuild.mod +++ b/gcc/m2/gm2-compiler/P2SymBuild.mod @@ -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: diff --git a/gcc/m2/gm2-compiler/SymbolTable.def b/gcc/m2/gm2-compiler/SymbolTable.def index ffc1a2c585f..c6c39d92962 100644 --- a/gcc/m2/gm2-compiler/SymbolTable.def +++ b/gcc/m2/gm2-compiler/SymbolTable.def @@ -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, diff --git a/gcc/m2/gm2-compiler/SymbolTable.mod b/gcc/m2/gm2-compiler/SymbolTable.mod index 01e431e269c..cc1a874b791 100644 --- a/gcc/m2/gm2-compiler/SymbolTable.mod +++ b/gcc/m2/gm2-compiler/SymbolTable.mod @@ -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. *) diff --git a/gcc/m2/gm2-gcc/m2decl.cc b/gcc/m2/gm2-gcc/m2decl.cc index fb4d7dcc4e6..ab409378673 100644 --- a/gcc/m2/gm2-gcc/m2decl.cc +++ b/gcc/m2/gm2-gcc/m2decl.cc @@ -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; diff --git a/gcc/m2/gm2-gcc/m2decl.def b/gcc/m2/gm2-gcc/m2decl.def index 036f903c002..6a1969336a2 100644 --- a/gcc/m2/gm2-gcc/m2decl.def +++ b/gcc/m2/gm2-gcc/m2decl.def @@ -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 ; (* diff --git a/gcc/m2/gm2-gcc/m2decl.h b/gcc/m2/gm2-gcc/m2decl.h index 13ecaafda2b..19dbb7be4e1 100644 --- a/gcc/m2/gm2-gcc/m2decl.h +++ b/gcc/m2/gm2-gcc/m2decl.h @@ -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); diff --git a/gcc/m2/gm2-gcc/m2except.cc b/gcc/m2/gm2-gcc/m2except.cc index 2f43b685b04..ab7df804558 100644 --- a/gcc/m2/gm2-gcc/m2except.cc +++ b/gcc/m2/gm2-gcc/m2except.cc @@ -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. */ diff --git a/gcc/testsuite/gm2/warnings/returntype/fail/badreturn.mod b/gcc/testsuite/gm2/warnings/returntype/fail/badreturn.mod new file mode 100644 index 00000000000..af7fd81cba2 --- /dev/null +++ b/gcc/testsuite/gm2/warnings/returntype/fail/badreturn.mod @@ -0,0 +1,11 @@ +MODULE badreturn ; + +PROCEDURE X (VAR Y : BOOLEAN) : BOOLEAN; +BEGIN + IF Y + THEN + RETURN FALSE + END +END X ; + +END badreturn. diff --git a/gcc/testsuite/gm2/warnings/returntype/fail/warnings-returntype-fail.exp b/gcc/testsuite/gm2/warnings/returntype/fail/warnings-returntype-fail.exp new file mode 100644 index 00000000000..aaebe1f07dd --- /dev/null +++ b/gcc/testsuite/gm2/warnings/returntype/fail/warnings-returntype-fail.exp @@ -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 +# . + +# 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 +} diff --git a/gcc/testsuite/gm2/warnings/returntype/pass/Termbase.mod b/gcc/testsuite/gm2/warnings/returntype/pass/Termbase.mod new file mode 100644 index 00000000000..0b47826321b --- /dev/null +++ b/gcc/testsuite/gm2/warnings/returntype/pass/Termbase.mod @@ -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 . + +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 +. *) + +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. diff --git a/gcc/testsuite/gm2/warnings/returntype/pass/goodreturn.mod b/gcc/testsuite/gm2/warnings/returntype/pass/goodreturn.mod new file mode 100644 index 00000000000..7b27949d403 --- /dev/null +++ b/gcc/testsuite/gm2/warnings/returntype/pass/goodreturn.mod @@ -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. diff --git a/gcc/testsuite/gm2/warnings/returntype/pass/keypressedsimple.mod b/gcc/testsuite/gm2/warnings/returntype/pass/keypressedsimple.mod new file mode 100644 index 00000000000..30d53477962 --- /dev/null +++ b/gcc/testsuite/gm2/warnings/returntype/pass/keypressedsimple.mod @@ -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. diff --git a/gcc/testsuite/gm2/warnings/returntype/pass/warnings-returntype-pass.exp b/gcc/testsuite/gm2/warnings/returntype/pass/warnings-returntype-pass.exp new file mode 100644 index 00000000000..1cde1ae5440 --- /dev/null +++ b/gcc/testsuite/gm2/warnings/returntype/pass/warnings-returntype-pass.exp @@ -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 +# . + +# 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 +}