public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
From: Gaius Mulley <gaius@gcc.gnu.org>
To: gcc-cvs@gcc.gnu.org
Subject: [gcc/devel/modula-2] Bugfix to catch assigning a standard procedure function to a const.
Date: Thu, 1 Dec 2022 22:02:37 +0000 (GMT) [thread overview]
Message-ID: <20221201220237.610A63858D3C@sourceware.org> (raw)
https://gcc.gnu.org/g:2ed9ad9b914d96eb717a69dace7c9b4461cb0662
commit 2ed9ad9b914d96eb717a69dace7c9b4461cb0662
Author: Gaius Mulley <gaiusmod2@gmail.com>
Date: Thu Dec 1 22:01:42 2022 +0000
Bugfix to catch assigning a standard procedure function to a const.
These bug fix the bug exposed when attempting to import from a local
module. They also include many token accuracy improvements.
gcc/m2/ChangeLog:
* gm2-compiler/M2Base.def (CheckExpressionCompatible):
Add tok parameter. (CheckAssignmentCompatible) Add tok
parameter. (CheckParameterCompatible) Add tok parameter.
* gm2-compiler/M2Base.mod (EmitTypeIncompatibleWarning):
Add tok parameter and use it within MetaErrorT2 calls.
(EmitTypeIncompatibleError) Add tok parameter and use it
within MetaErrorT2 calls. (CheckCompatible) Add tok
parameter and use it within error messages.
* gm2-compiler/M2MetaError.mod (symDesc): Add standard
procedure and standard function procedure description.
* gm2-compiler/M2Quads.mod (CheckCompatibleWithBecomes)
Add tok parameter. (CheckBecomesMeta) Add
combinedtok, destok, exprtok. (CheckAssignCompatible) Add
combinedtok, destok, exprtok.
* gm2-compiler/P0SymBuild.mod: Reformatted.
(RegisterLocalModule) Fix modname/name bug. (RegisterImports)
Fix n/modname bug.
* gm2-compiler/PCSymBuild.mod (PushConstFunctionType): Use
token position when generating error messages.
gcc/testsuite/gm2/ChangeLog:
* iso/fail/realbitscast.mod: Minor formatting changes.
Signed-off-by: Gaius Mulley <gaiusmod2@gmail.com>
Diff:
---
gcc/m2/gm2-compiler/M2Base.def | 9 +-
gcc/m2/gm2-compiler/M2Base.mod | 71 ++++++++-----
gcc/m2/gm2-compiler/M2MetaError.mod | 8 +-
gcc/m2/gm2-compiler/M2Quads.mod | 82 +++++++++------
gcc/m2/gm2-compiler/P0SymBuild.mod | 148 +++++++++++++---------------
gcc/m2/gm2-compiler/PCSymBuild.mod | 61 ++++++------
gcc/testsuite/gm2/iso/fail/realbitscast.mod | 6 +-
7 files changed, 218 insertions(+), 167 deletions(-)
diff --git a/gcc/m2/gm2-compiler/M2Base.def b/gcc/m2/gm2-compiler/M2Base.def
index abe4036d4cd..e15fd09a690 100644
--- a/gcc/m2/gm2-compiler/M2Base.def
+++ b/gcc/m2/gm2-compiler/M2Base.def
@@ -314,7 +314,8 @@ PROCEDURE IsValidParameter (formal, actual: CARDINAL) : BOOLEAN ;
message is displayed.
*)
-PROCEDURE CheckExpressionCompatible (t1, t2: CARDINAL) ;
+PROCEDURE CheckExpressionCompatible (tok: CARDINAL;
+ left, right: CARDINAL) ;
(*
@@ -324,7 +325,8 @@ PROCEDURE CheckExpressionCompatible (t1, t2: CARDINAL) ;
message is displayed.
*)
-PROCEDURE CheckAssignmentCompatible (t1, t2: CARDINAL) ;
+PROCEDURE CheckAssignmentCompatible (tok: CARDINAL;
+ left, right: CARDINAL) ;
(*
@@ -332,7 +334,8 @@ PROCEDURE CheckAssignmentCompatible (t1, t2: CARDINAL) ;
compatible for parameter passing.
*)
-PROCEDURE CheckParameterCompatible (t1, t2: CARDINAL) ;
+PROCEDURE CheckParameterCompatible (tok: CARDINAL;
+ t1, t2: CARDINAL) ;
(*
diff --git a/gcc/m2/gm2-compiler/M2Base.mod b/gcc/m2/gm2-compiler/M2Base.mod
index bb112166df5..d5a0ccf8ad8 100644
--- a/gcc/m2/gm2-compiler/M2Base.mod
+++ b/gcc/m2/gm2-compiler/M2Base.mod
@@ -1127,14 +1127,23 @@ END GetCmplxReturnType ;
EmitTypeIncompatibleWarning - emit a type incompatibility warning.
*)
-PROCEDURE EmitTypeIncompatibleWarning (kind: Compatability; t1, t2: CARDINAL) ;
+PROCEDURE EmitTypeIncompatibleWarning (tok: CARDINAL;
+ kind: Compatability; t1, t2: CARDINAL) ;
BEGIN
CASE kind OF
- expression: MetaError2('{%1W:} type incompatibility found {%1as:{%2as:between types {%1as} {%2as}}} in an expression, hint one of the expressions should be converted', t1, t2) |
- assignment: MetaError2('{%1W:} type incompatibility found {%1as:{%2as:between types {%1as} {%2as}}} during an assignment, hint maybe the expression should be converted', t1, t2) |
- parameter : MetaError2('{%1W:} type incompatibility found when passing a parameter {%1as:{%2as:between formal parameter and actual parameter types {%1as} {%2as}}}, hint the actual parameter {%2a} should be converted', t1, t2) |
- comparison: MetaError2('{%1W:} type incompatibility found {%1as:{%2as:between types {%1as} {%2as}}} in a relational expression, hint one of the expressions should be converted', t1, t2)
+ expression: MetaErrorT2 (tok,
+ '{%1W:} type incompatibility found {%1as:{%2as:between types {%1as} {%2as}}} in an expression, hint one of the expressions should be converted',
+ t1, t2) |
+ assignment: MetaErrorT2 (tok,
+ '{%1W:} type incompatibility found {%1as:{%2as:between types {%1as} {%2as}}} during an assignment, hint maybe the expression should be converted',
+ t1, t2) |
+ parameter : MetaErrorT2 (tok,
+ '{%1W:} type incompatibility found when passing a parameter {%1as:{%2as:between formal parameter and actual parameter types {%1as} {%2as}}}, hint the actual parameter {%2a} should be converted',
+ t1, t2) |
+ comparison: MetaErrorT2 (tok,
+ '{%1W:} type incompatibility found {%1as:{%2as:between types {%1as} {%2as}}} in a relational expression, hint one of the expressions should be converted',
+ t1, t2)
ELSE
END
@@ -1145,14 +1154,23 @@ END EmitTypeIncompatibleWarning ;
EmitTypeIncompatibleError - emit a type incompatibility error.
*)
-PROCEDURE EmitTypeIncompatibleError (kind: Compatability; t1, t2: CARDINAL) ;
+PROCEDURE EmitTypeIncompatibleError (tok: CARDINAL;
+ kind: Compatability; t1, t2: CARDINAL) ;
BEGIN
CASE kind OF
- expression: MetaError2('type incompatibility found {%1as:{%2as:between types {%1as} and {%2as}}} in an expression, hint one of the expressions should be converted', t1, t2) |
- assignment: MetaError2('type incompatibility found {%1as:{%2as:between types {%1as} and {%2as}}} during an assignment, hint maybe the expression should be converted', t1, t2) |
- parameter : MetaError2('type incompatibility found when passing a parameter {%1as:{%2as:between formal parameter and actual parameter types {%1as} and {%2as}}}, hint the actual parameter should be converted', t1, t2) |
- comparison: MetaError2('type incompatibility found {%1as:{%2as:between types {%1as} and {%2as}}} in a relational expression, hint one of the expressions should be converted', t1, t2)
+ expression: MetaErrorT2 (tok,
+ 'type incompatibility found {%1as:{%2as:between types {%1as} and {%2as}}} in an expression, hint one of the expressions should be converted',
+ t1, t2) |
+ assignment: MetaErrorT2 (tok,
+ 'type incompatibility found {%1as:{%2as:between types {%1as} and {%2as}}} during an assignment, hint maybe the expression should be converted',
+ t1, t2) |
+ parameter : MetaErrorT2 (tok,
+ 'type incompatibility found when passing a parameter {%1as:{%2as:between formal parameter and actual parameter types {%1as} and {%2as}}}, hint the actual parameter should be converted',
+ t1, t2) |
+ comparison: MetaErrorT2 (tok,
+ 'type incompatibility found {%1as:{%2as:between types {%1as} and {%2as}}} in a relational expression, hint one of the expressions should be converted',
+ t1, t2)
ELSE
END
@@ -1163,7 +1181,8 @@ END EmitTypeIncompatibleError ;
CheckCompatible - returns if t1 and t2 are kind compatible
*)
-PROCEDURE CheckCompatible (t1, t2: CARDINAL; kind: Compatability) ;
+PROCEDURE CheckCompatible (tok: CARDINAL;
+ t1, t2: CARDINAL; kind: Compatability) ;
VAR
s: String ;
r: Compatible ;
@@ -1180,21 +1199,21 @@ BEGIN
IF IsUnknown(t1) AND IsUnknown(t2)
THEN
s := ConCat(s, InitString('two different unknown types {%1a:{%2a:{%1a} and {%2a}}} must either be declared or imported)')) ;
- MetaErrorStringT2(GetTokenNo(), s, t1, t2)
+ MetaErrorStringT2 (tok, s, t1, t2)
ELSIF IsUnknown(t1)
THEN
s := ConCat(s, InitString('this type {%1a} is currently unknown, it must be declared or imported')) ;
- MetaErrorStringT1(GetTokenNo(), s, t1)
+ MetaErrorStringT1 (tok, s, t1)
ELSIF IsUnknown(t2)
THEN
- s := ConCat(s, InitString('this type {%1a} is currently unknown, it must be declared or imported')) ;
- MetaErrorStringT1(GetTokenNo(), s, t2)
+ s := ConCat (s, InitString('this type {%1a} is currently unknown, it must be declared or imported')) ;
+ MetaErrorStringT1 (tok, s, t2)
ELSE
IF (r=warnfirst) OR (r=warnsecond)
THEN
- EmitTypeIncompatibleWarning(kind, t1, t2)
+ EmitTypeIncompatibleWarning (tok, kind, t1, t2)
ELSE
- EmitTypeIncompatibleError(kind, t1, t2)
+ EmitTypeIncompatibleError (tok, kind, t1, t2)
END
END
END
@@ -1208,9 +1227,9 @@ END CheckCompatible ;
message is displayed.
*)
-PROCEDURE CheckExpressionCompatible (t1, t2: CARDINAL) ;
+PROCEDURE CheckExpressionCompatible (tok: CARDINAL; left, right: CARDINAL) ;
BEGIN
- CheckCompatible(t1, t2, expression)
+ CheckCompatible (tok, left, right, expression)
END CheckExpressionCompatible ;
@@ -1219,9 +1238,10 @@ END CheckExpressionCompatible ;
compatible for parameter passing.
*)
-PROCEDURE CheckParameterCompatible (t1, t2: CARDINAL) ;
+PROCEDURE CheckParameterCompatible (tok: CARDINAL;
+ t1, t2: CARDINAL) ;
BEGIN
- CheckCompatible(t1, t2, parameter)
+ CheckCompatible (tok, t1, t2, parameter)
END CheckParameterCompatible ;
@@ -1232,11 +1252,12 @@ END CheckParameterCompatible ;
message is displayed.
*)
-PROCEDURE CheckAssignmentCompatible (t1, t2: CARDINAL) ;
+PROCEDURE CheckAssignmentCompatible (tok: CARDINAL;
+ left, right: CARDINAL) ;
BEGIN
- IF t1#t2
+ IF left # right
THEN
- CheckCompatible(t1, t2, assignment)
+ CheckCompatible (tok, left, right, assignment)
END
END CheckAssignmentCompatible ;
@@ -1967,7 +1988,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 {%1as} and {%2as}', t1, t2) ;
FlushErrors (* unrecoverable at present *) |
warnfirst,
first : RETURN( t1 ) |
diff --git a/gcc/m2/gm2-compiler/M2MetaError.mod b/gcc/m2/gm2-compiler/M2MetaError.mod
index 1e292f68dab..08c0985f7d2 100644
--- a/gcc/m2/gm2-compiler/M2MetaError.mod
+++ b/gcc/m2/gm2-compiler/M2MetaError.mod
@@ -22,7 +22,7 @@ along with GNU Modula-2; see the file COPYING3. If not see
IMPLEMENTATION MODULE M2MetaError ;
-FROM M2Base IMPORT ZType, RType ;
+FROM M2Base IMPORT ZType, RType, IsPseudoBaseFunction, IsPseudoBaseProcedure ;
FROM NameKey IMPORT Name, KeyToCharStar, NulName ;
FROM StrLib IMPORT StrLen ;
FROM M2LexBuf IMPORT GetTokenNo, UnknownTokenNo ;
@@ -1384,6 +1384,12 @@ BEGIN
ELSIF IsProcType(sym)
THEN
RETURN InitString('procedure type')
+ ELSIF IsPseudoBaseFunction (sym)
+ THEN
+ RETURN InitString('standard function procedure')
+ ELSIF IsPseudoBaseProcedure (sym)
+ THEN
+ RETURN InitString('standard procedure')
ELSIF IsProcedure(sym)
THEN
RETURN InitString('procedure')
diff --git a/gcc/m2/gm2-compiler/M2Quads.mod b/gcc/m2/gm2-compiler/M2Quads.mod
index c3087fa96ce..2ff4d54c950 100644
--- a/gcc/m2/gm2-compiler/M2Quads.mod
+++ b/gcc/m2/gm2-compiler/M2Quads.mod
@@ -34,7 +34,7 @@ FROM M2Scaffold IMPORT DeclareScaffold, mainFunction, initFunction,
FROM M2MetaError IMPORT MetaError0, MetaError1, MetaError2, MetaError3,
MetaErrors1, MetaErrors2, MetaErrors3,
MetaErrorT0, MetaErrorT1, MetaErrorT2,
- MetaErrorsT1,
+ MetaErrorsT1, MetaErrorsT2,
MetaErrorStringT0, MetaErrorStringT1,
MetaErrorString1, MetaErrorString2,
MetaErrorN1, MetaErrorN2,
@@ -3037,17 +3037,26 @@ END BackPatchSubrangesAndOptParam ;
compatible with the := operator.
*)
-PROCEDURE CheckCompatibleWithBecomes (sym: CARDINAL) ;
+PROCEDURE CheckCompatibleWithBecomes (des, expr,
+ destok, exprtok: CARDINAL) ;
BEGIN
- IF IsType(sym)
+ IF IsType (des)
THEN
- MetaError1 ('an assignment cannot assign a value to a type {%1a}', sym)
- ELSIF IsProcedure(sym)
+ MetaErrorT1 (destok,
+ 'an assignment cannot assign a value to a type {%1a}', des)
+ ELSIF IsProcedure (des)
THEN
- MetaError1 ('an assignment cannot assign a value to a procedure {%1a}', sym)
- ELSIF IsFieldEnumeration(sym)
+ MetaErrorT1 (destok,
+ 'an assignment cannot assign a value to a procedure {%1a}', des)
+ ELSIF IsFieldEnumeration (des)
THEN
- MetaError1 ('an assignment cannot assign a value to an enumeration field {%1a}', sym)
+ MetaErrorT1 (destok,
+ 'an assignment cannot assign a value to an enumeration field {%1a}', des)
+ END ;
+ IF IsPseudoBaseProcedure (expr) OR IsPseudoBaseFunction (expr)
+ THEN
+ MetaErrorT1 (exprtok,
+ 'an assignment cannot assign a {%1d} {%1a}', expr)
END
END CheckCompatibleWithBecomes ;
@@ -3286,20 +3295,23 @@ END BuildBuiltinTypeInfo ;
unbounded array.
*)
-PROCEDURE CheckBecomesMeta (Des, Exp: CARDINAL) ;
+PROCEDURE CheckBecomesMeta (Des, Exp: CARDINAL; combinedtok, destok, exprtok: CARDINAL) ;
BEGIN
- IF IsConst(Des) AND IsVar(Exp)
+ IF IsConst (Des) AND IsVar (Exp)
THEN
- MetaErrors2('in assignment, cannot assign a variable {%2a} to a constant {%1a}',
- 'designator {%1Da} is declared as a CONST', Des, Exp)
+ MetaErrorsT2 (combinedtok,
+ 'in assignment, cannot assign a variable {%2a} to a constant {%1a}',
+ 'designator {%1Da} is declared as a {%kCONST}', Des, Exp)
END ;
- IF (GetDType(Des)#NulSym) AND IsVar(Des) AND IsUnbounded(GetDType(Des))
+ IF (GetDType(Des) # NulSym) AND IsVar (Des) AND IsUnbounded (GetDType (Des))
THEN
- MetaError1('in assignment, cannot assign to an unbounded array {%1ad}', Des)
+ MetaErrorT1 (destok,
+ 'in assignment, cannot assign to an unbounded array {%1ad}', Des)
END ;
- IF (GetDType(Exp)#NulSym) AND IsVar(Exp) AND IsUnbounded(GetDType(Exp))
+ IF (GetDType(Exp) # NulSym) AND IsVar (Exp) AND IsUnbounded (GetDType (Exp))
THEN
- MetaError1('in assignment, cannot assign from an unbounded array {%1ad}', Exp)
+ MetaErrorT1 (exprtok,
+ 'in assignment, cannot assign from an unbounded array {%1ad}', Exp)
END
END CheckBecomesMeta ;
@@ -3498,7 +3510,7 @@ BEGIN
Array := OperandA (1) ;
PopTrwtok (Des, w, destok) ;
MarkAsWrite (w) ;
- CheckCompatibleWithBecomes (Des) ;
+ CheckCompatibleWithBecomes (Des, Exp, destok, exptok) ;
combinedtok := MakeVirtualTok (becomesTokNo, destok, exptok) ;
IF (GetSType (Des) # NulSym) AND (NOT IsSet (GetDType (Des)))
THEN
@@ -3508,7 +3520,7 @@ BEGIN
END ;
IF checkTypes
THEN
- CheckBecomesMeta (Des, Exp)
+ CheckBecomesMeta (Des, Exp, combinedtok, destok, exptok)
END ;
(* Traditional Assignment. *)
MoveWithMode (becomesTokNo, Des, Exp, Array, destok, exptok, checkOverflow) ;
@@ -3524,7 +3536,7 @@ BEGIN
END ;
*)
(* BuildRange (InitTypesAssignmentCheck (combinedtok, Des, Exp)) ; *)
- CheckAssignCompatible (Des, Exp)
+ CheckAssignCompatible (Des, Exp, combinedtok, destok, exptok)
END
END ;
DisplayStack
@@ -3538,7 +3550,7 @@ END doBuildAssignment ;
given knowledge so far.
*)
-PROCEDURE CheckAssignCompatible (Des, Exp: CARDINAL) ;
+PROCEDURE CheckAssignCompatible (Des, Exp: CARDINAL; combinedtok, destok, exprtok: CARDINAL) ;
VAR
DesT, ExpT, DesL: CARDINAL ;
BEGIN
@@ -3549,10 +3561,12 @@ BEGIN
((DesT#NulSym) AND (NOT IsProcType(DesT))) AND
((DesL#NulSym) AND (NOT IsProcType(DesL)))
THEN
- MetaError1 ('incorrectly assigning a procedure to a designator {%1Ead} (designator is not a procedure type, {%1ast})', Des)
+ MetaErrorT1 (combinedtok,
+ 'incorrectly assigning a procedure to a designator {%1Ead} (designator is not a procedure type, {%1ast})', Des)
ELSIF IsProcedure (Exp) AND IsProcedureNested (Exp)
THEN
- MetaError1 ('cannot call nested procedure {%1Ead} indirectly as the outer scope will not be known', Exp)
+ MetaErrorT1 (exprtok,
+ 'cannot call nested procedure {%1Ead} indirectly as the outer scope will not be known', Exp)
ELSIF IsConstString(Exp)
THEN
ELSIF (DesT#NulSym) AND (IsUnbounded(DesT))
@@ -3571,7 +3585,8 @@ BEGIN
PutConst(Des, ExpT)
ELSIF NOT IsAssignmentCompatible(DesT, ExpT)
THEN
- MetaError1 ('constructor expression is not compatible during assignment to {%1Ead}', Des)
+ MetaErrorT1 (combinedtok,
+ 'constructor expression is not compatible during assignment to {%1Ead}', Des)
END
ELSIF (DesT#NulSym) AND IsSet(DesT) AND IsConst(Exp)
THEN
@@ -3582,16 +3597,17 @@ BEGIN
THEN
IF (IsBaseType(DesL) OR IsSystemType(DesL))
THEN
- CheckAssignmentCompatible(ExpT, DesT)
+ CheckAssignmentCompatible (combinedtok, ExpT, DesT)
ELSE
- MetaError2 ('assignment of a constant {%1Ead} can only be made to a variable whose type is equivalent to a Modula-2 base type {%2tsa}', Exp, Des)
+ MetaErrorT2 (combinedtok,
+ 'assignment of a constant {%1Ead} can only be made to a variable whose type is equivalent to a Modula-2 base type {%2tsa}', Exp, Des)
END
ELSE
IF (DesT#NulSym) AND IsProcType(DesT) AND IsProcedure(Exp)
THEN
DesT := GetSType(DesT) ; (* we can at least check RETURN values of procedure variables *)
(* remember that thorough assignment checking is done post pass 3 *)
- CheckAssignmentCompatible(ExpT, DesT)
+ CheckAssignmentCompatible (combinedtok, ExpT, DesT)
END
END
END CheckAssignCompatible ;
@@ -4353,18 +4369,18 @@ BEGIN
THEN
MetaError2 ('incompatible types found in {%EkFOR} loop header, initial expression {%E1tsad} and final expression {%E2tsad}',
e1, e2) ;
- CheckExpressionCompatible (GetSType (e1), GetSType (e2))
+ CheckExpressionCompatible (idtok, GetSType (e1), GetSType (e2))
END ;
IF NOT IsExpressionCompatible( GetSType (e1), ByType)
THEN
MetaError2 ('incompatible types found in {%EkFOR} loop header, initial expression {%E1tsad} and {%kBY} {%E2tsad}',
e2, BySym) ;
- CheckExpressionCompatible (GetSType (e1), ByType)
+ CheckExpressionCompatible (e1tok, GetSType (e1), ByType)
ELSIF NOT IsExpressionCompatible (GetSType (e2), ByType)
THEN
MetaError2 ('incompatible types found in {%EkFOR} loop header, final expression {%E1tsad} and {%kBY} {%E2tsad}',
e2, BySym) ;
- CheckExpressionCompatible (GetSType (e2), ByType)
+ CheckExpressionCompatible (e1tok, GetSType (e2), ByType)
END ;
BuildRange (InitForLoopBeginRangeCheck (IdSym, e1)) ;
PushTtok (IdSym, idtok) ;
@@ -7432,9 +7448,15 @@ VAR
NoOfParam,
ProcSym : CARDINAL ;
BEGIN
+ DisplayStack ;
PopT(NoOfParam) ;
ProcSym := OperandT (NoOfParam + 1) ;
functok := OperandTtok (NoOfParam + 1) ;
+ IF CompilerDebugging
+ THEN
+ printf2 ('procsym = %d token = %d\n', ProcSym, functok) ;
+ ErrorStringAt (InitString ('constant function'), functok)
+ END ;
PushT (NoOfParam) ;
IF (ProcSym # Convert) AND
(IsPseudoBaseFunction (ProcSym) OR
@@ -9795,7 +9817,7 @@ BEGIN
IF (IsVar(l) OR IsConst(l)) AND
(IsVar(r) OR IsConst(r))
THEN
- CheckExpressionCompatible (GetSType(l), GetSType(r)) ;
+ CheckExpressionCompatible (combinedtok, GetSType(l), GetSType(r)) ;
ReturnVar := MakeTemporary (combinedtok, AreConstant (IsConst (l) AND IsConst (r))) ;
PutVar (ReturnVar, GetCmplxReturnType (GetDType (l), GetDType (r))) ;
GenQuadO (combinedtok, StandardFunctionOp, ReturnVar, Cmplx, Make2Tuple (l, r), TRUE) ;
diff --git a/gcc/m2/gm2-compiler/P0SymBuild.mod b/gcc/m2/gm2-compiler/P0SymBuild.mod
index 7c3ff661365..fa44d889f1c 100644
--- a/gcc/m2/gm2-compiler/P0SymBuild.mod
+++ b/gcc/m2/gm2-compiler/P0SymBuild.mod
@@ -74,9 +74,9 @@ VAR
PROCEDURE nSpaces (n: CARDINAL) ;
BEGIN
- WHILE n>0 DO
- printf0(" ") ;
- DEC(n)
+ WHILE n > 0 DO
+ printf0 (" ") ;
+ DEC (n)
END
END nSpaces ;
@@ -89,10 +89,10 @@ PROCEDURE DisplayB (b: BlockInfoPtr) ;
BEGIN
CASE b^.kind OF
- program : printf1("MODULE %a ;\n", b^.name) |
- defimp : printf1("DEFIMP %a ;\n", b^.name) |
- inner : printf1("INNER MODULE %a ;\n", b^.name) |
- procedure: printf1("PROCEDURE %a ;\n", b^.name)
+ program : printf1 ("MODULE %a ;\n", b^.name) |
+ defimp : printf1 ("DEFIMP %a ;\n", b^.name) |
+ inner : printf1 ("INNER MODULE %a ;\n", b^.name) |
+ procedure: printf1 ("PROCEDURE %a ;\n", b^.name)
ELSE
HALT
@@ -108,17 +108,17 @@ PROCEDURE DisplayBlock (b: BlockInfoPtr; l: CARDINAL) ;
VAR
a: BlockInfoPtr ;
BEGIN
- nSpaces(l) ;
- DisplayB(b) ;
+ nSpaces (l) ;
+ DisplayB (b) ;
a := b^.toDown ;
- INC(l, 3) ;
- WHILE a#NIL DO
- DisplayBlock(a, l) ;
+ INC (l, 3) ;
+ WHILE a # NIL DO
+ DisplayBlock (a, l) ;
a := a^.toNext
END ;
- DEC(l, 3) ;
- nSpaces(l) ;
- printf1("END %a\n", b^.name)
+ DEC (l, 3) ;
+ nSpaces (l) ;
+ printf1 ("END %a\n", b^.name)
END DisplayBlock ;
@@ -129,7 +129,7 @@ END DisplayBlock ;
(*
PROCEDURE pc ;
BEGIN
- DisplayB(curBP)
+ DisplayB (curBP)
END pc ;
*)
@@ -142,12 +142,12 @@ PROCEDURE Display ;
VAR
b: BlockInfoPtr ;
BEGIN
- printf0("Universe of Modula-2 modules\n") ;
- IF headBP#NIL
+ printf0 ("Universe of Modula-2 modules\n") ;
+ IF headBP # NIL
THEN
b := headBP^.toDown ;
- WHILE b#NIL DO
- DisplayBlock(b, 0) ;
+ WHILE b # NIL DO
+ DisplayBlock (b, 0) ;
b := b^.toNext
END
END
@@ -160,12 +160,12 @@ END Display ;
PROCEDURE addDown (a, b: BlockInfoPtr) ;
BEGIN
- IF a^.toDown=NIL
+ IF a^.toDown = NIL
THEN
a^.toDown := b
ELSE
a := a^.toDown ;
- WHILE a^.toNext#NIL DO
+ WHILE a^.toNext # NIL DO
a := a^.toNext
END ;
a^.toNext := b
@@ -179,21 +179,21 @@ END addDown ;
PROCEDURE GraftBlock (b: BlockInfoPtr) ;
BEGIN
- Assert(curBP#NIL) ;
- Assert(ABS(Level-curBP^.level)<=1) ;
+ Assert (curBP # NIL) ;
+ Assert (ABS (Level-curBP^.level) <= 1) ;
CASE Level-curBP^.level OF
-1: (* returning up to the outer scope *)
curBP := curBP^.toUp ;
- Assert(curBP^.toNext=NIL) ;
+ Assert (curBP^.toNext = NIL) ;
curBP^.toNext := b |
0: (* add toNext *)
- Assert(curBP^.toNext=NIL) ;
+ Assert (curBP^.toNext = NIL) ;
curBP^.toNext := b ;
b^.toUp := curBP^.toUp |
+1: (* insert down a level *)
b^.toUp := curBP ; (* save return value *)
- addDown(curBP, b)
+ addDown (curBP, b)
ELSE
HALT
@@ -211,7 +211,7 @@ PROCEDURE BeginBlock (n: Name; k: Kind; s: CARDINAL; tok: CARDINAL) ;
VAR
b: BlockInfoPtr ;
BEGIN
- NEW(b) ;
+ NEW (b) ;
WITH b^ DO
name := n ;
kind := k ;
@@ -236,7 +236,7 @@ END BeginBlock ;
PROCEDURE InitUniverse ;
BEGIN
- NEW(curBP) ;
+ NEW (curBP) ;
WITH curBP^ DO
name := NulName ;
kind := universe ;
@@ -282,12 +282,12 @@ END FlushImports ;
PROCEDURE EndBlock ;
BEGIN
- FlushImports(curBP) ;
+ FlushImports (curBP) ;
curBP := curBP^.toUp ;
- DEC(Level) ;
- IF Level=0
+ DEC (Level) ;
+ IF Level = 0
THEN
- FlushImports(curBP)
+ FlushImports (curBP)
END
END EndBlock ;
@@ -296,23 +296,24 @@ END EndBlock ;
RegisterLocalModule - register, n, as a local module.
*)
-PROCEDURE RegisterLocalModule (name: Name) ;
+PROCEDURE RegisterLocalModule (modname: Name) ;
VAR
i, n: CARDINAL ;
desc: ModuleDesc ;
BEGIN
(* printf1('seen local module %a\n', n) ; *)
WITH curBP^ DO
- IncludeItemIntoList (LocalModules, n) ;
+ IncludeItemIntoList (LocalModules, modname) ;
i := LowIndice (ImportedModules) ;
n := HighIndice (ImportedModules) ;
WHILE i <= n DO
desc := GetIndice (ImportedModules, i) ;
- IF desc^.name = name
+ IF desc^.name = modname
THEN
RemoveIndiceFromIndex (ImportedModules, desc) ;
DISPOSE (desc) ;
- RETURN (* All done. *)
+ DEC (n)
+ (* Continue checking in case a user imported the same module again. *)
ELSE
INC (i)
END
@@ -325,20 +326,20 @@ END RegisterLocalModule ;
RegisterImport - register, n, as a module imported from either a local scope or definition module.
*)
-PROCEDURE RegisterImport (n: Name; tok: CARDINAL) ;
+PROCEDURE RegisterImport (tok: CARDINAL; modname: Name) ;
VAR
bp : BlockInfoPtr ;
desc: ModuleDesc ;
BEGIN
(* printf1('register import from module %a\n', n) ; *)
- Assert(curBP#NIL) ;
- Assert(curBP^.toUp#NIL) ;
+ Assert (curBP # NIL) ;
+ Assert (curBP^.toUp # NIL) ;
bp := curBP^.toUp ; (* skip over current module *)
WITH bp^ DO
- IF NOT IsItemInList (LocalModules, n)
+ IF NOT IsItemInList (LocalModules, modname)
THEN
NEW (desc) ;
- desc^.name := n ;
+ desc^.name := modname ;
desc^.tok := tok ;
IncludeIndiceIntoIndex (ImportedModules, desc)
END
@@ -355,21 +356,21 @@ VAR
index,
i, n : CARDINAL ;
BEGIN
- PopT(n) ; (* n = # of the Ident List *)
- IF OperandT(n+1)=ImportTok
+ PopT (n) ; (* n = # of the Ident List *)
+ IF OperandT (n+1) = ImportTok
THEN
(* Ident list contains Module Names *)
i := 1 ;
WHILE i<=n DO
index := n+1-i ;
- RegisterImport (OperandT (index), OperandTok (index)) ;
- INC(i)
+ RegisterImport (OperandTok (index), OperandT (index)) ;
+ INC (i)
END
ELSE
(* Ident List contains list of objects *)
- RegisterImport (OperandT (n+1), OperandTok (n+1))
+ RegisterImport (OperandTok (n+1), OperandT (n+1))
END ;
- PopN(n+1) (* clear stack *)
+ PopN (n+1) (* clear stack *)
END RegisterImports ;
@@ -381,20 +382,13 @@ PROCEDURE RegisterInnerImports ;
VAR
n: CARDINAL ;
BEGIN
- PopT(n) ; (* n = # of the Ident List *)
- IF OperandT(n+1)=ImportTok
+ PopT (n) ; (* n = # of the Ident List *)
+ IF OperandT (n+1) = ImportTok
THEN
- (* Ident list contains list of objects, which will be seen outside the scope of this module *)
-(*
- i := 1 ;
- WHILE i<=n DO
- RegisterImport(OperandT(n+1-i)) ;
- INC(i)
- END
-*)
+ (* Ident list contains list of objects, which will be seen outside the scope of this module. *)
ELSE
(* Ident List contains list of objects, but we are importing directly from a module OperandT(n+1) *)
- RegisterImport (OperandT (n+1), OperandTok (n+1))
+ RegisterImport (OperandTok (n+1), OperandT (n+1))
END ;
PopN (n+1) (* clear stack *)
END RegisterInnerImports ;
@@ -410,7 +404,7 @@ VAR
sym: CARDINAL ;
tok: CARDINAL ;
BEGIN
- Assert (Level=0) ;
+ Assert (Level = 0) ;
INC (Level) ;
PopTtok (n, tok) ;
PushTtok (n, tok) ;
@@ -432,7 +426,7 @@ VAR
sym: CARDINAL ;
tok: CARDINAL ;
BEGIN
- Assert (Level=0) ;
+ Assert (Level = 0) ;
INC (Level) ;
PopTtok (n, tok) ;
PushTtok (n, tok) ;
@@ -481,7 +475,7 @@ VAR
n : Name ;
tok: CARDINAL ;
BEGIN
- INC(Level) ;
+ INC (Level) ;
PopTtok (n, tok) ;
PushTtok (n, tok) ;
RegisterLocalModule (n) ;
@@ -660,7 +654,7 @@ PROCEDURE Move ;
VAR
b: BlockInfoPtr ;
BEGIN
- IF Level=curBP^.level
+ IF Level = curBP^.level
THEN
b := curBP^.toReturn ;
(* moving to next *)
@@ -668,8 +662,8 @@ BEGIN
(* remember our return *)
curBP^.toReturn := b
ELSE
- WHILE Level#curBP^.level DO
- IF Level<curBP^.level
+ WHILE Level # curBP^.level DO
+ IF Level < curBP^.level
THEN
(* move up to the outer scope *)
b := curBP ;
@@ -679,12 +673,12 @@ BEGIN
(* move down a level *)
(* remember where we came from *)
b := curBP ;
- IF curBP^.toPC=NIL
+ IF curBP^.toPC = NIL
THEN
- Assert(curBP^.toDown#NIL) ;
+ Assert (curBP^.toDown#NIL) ;
curBP^.toPC := curBP^.toDown
END ;
- Assert(curBP^.toPC#NIL) ;
+ Assert (curBP^.toPC#NIL) ;
curBP := curBP^.toPC ;
curBP^.toReturn := b
END
@@ -699,20 +693,20 @@ END Move ;
PROCEDURE EnterBlock (n: Name) ;
BEGIN
- Assert(curBP#NIL) ;
- INC(Level) ;
+ Assert (curBP#NIL) ;
+ INC (Level) ;
Move ;
IF Debugging
THEN
- nSpaces(Level*3) ;
- IF n=curBP^.name
+ nSpaces (Level*3) ;
+ IF n = curBP^.name
THEN
- printf1('block %a\n', n)
+ printf1 ('block %a\n', n)
ELSE
- printf2('seen block %a but tree has recorded %a\n', n, curBP^.name)
+ printf2 ('seen block %a but tree has recorded %a\n', n, curBP^.name)
END
END ;
- Assert((n=curBP^.name) OR (curBP^.name=NulName)) ;
+ Assert ((n = curBP^.name) OR (curBP^.name = NulName)) ;
DeclareModules
END EnterBlock ;
@@ -725,9 +719,9 @@ PROCEDURE LeaveBlock ;
BEGIN
IF Debugging
THEN
- printf1('leaving block %a ', curBP^.name)
+ printf1 ('leaving block %a ', curBP^.name)
END ;
- DEC(Level) ;
+ DEC (Level) ;
Move
END LeaveBlock ;
diff --git a/gcc/m2/gm2-compiler/PCSymBuild.mod b/gcc/m2/gm2-compiler/PCSymBuild.mod
index f3d3afce8f0..57d77e1b2f5 100644
--- a/gcc/m2/gm2-compiler/PCSymBuild.mod
+++ b/gcc/m2/gm2-compiler/PCSymBuild.mod
@@ -28,7 +28,7 @@ FROM StrIO IMPORT WriteString, WriteLn ;
FROM NumberIO IMPORT WriteCard ;
FROM M2Debug IMPORT Assert, WriteDebug ;
FROM M2Error IMPORT WriteFormat0, WriteFormat1, WriteFormat2, FlushErrors, InternalError, NewError, ErrorFormat0 ;
-FROM M2MetaError IMPORT MetaError1 ;
+FROM M2MetaError IMPORT MetaError1, MetaErrorT1 ;
FROM M2LexBuf IMPORT GetTokenNo ;
FROM M2Reserved IMPORT NulTok, ImportTok ;
FROM M2Const IMPORT constType ;
@@ -510,19 +510,19 @@ VAR
Sym, ModSym,
i, n : CARDINAL ;
BEGIN
- PopT(n) ; (* n = # of the Ident List *)
- IF OperandT(n+1)#ImportTok
+ PopT (n) ; (* n = # of the Ident List *)
+ IF OperandT (n+1) # ImportTok
THEN
(* Ident List contains list of objects imported from ModSym *)
- ModSym := LookupModule(OperandTok(n+1), OperandT(n+1)) ;
+ ModSym := LookupModule (OperandTok (n+1), OperandT (n+1)) ;
i := 1 ;
WHILE i<=n DO
Sym := GetExported (OperandTok (i), ModSym, OperandT (i)) ;
- CheckForEnumerationInCurrentModule(Sym) ;
- INC(i)
+ CheckForEnumerationInCurrentModule (Sym) ;
+ INC (i)
END
END ;
- PopN(n+1) (* clear stack *)
+ PopN (n+1) (* clear stack *)
END PCBuildImportOuterModule ;
@@ -568,8 +568,8 @@ BEGIN
i := 1 ;
WHILE i<=n DO
Sym := GetFromOuterModule (OperandTok (i), OperandT (i)) ;
- CheckForEnumerationInCurrentModule(Sym) ;
- INC(i)
+ CheckForEnumerationInCurrentModule (Sym) ;
+ INC (i)
END
ELSE
(* Ident List contains list of objects imported from ModSym *)
@@ -686,10 +686,10 @@ VAR
ProcSym : CARDINAL ;
NameStart: Name ;
BEGIN
- IF CompilingDefinitionModule()
+ IF CompilingDefinitionModule ()
THEN
- PopT(ProcSym) ;
- PopT(NameStart) ;
+ PopT (ProcSym) ;
+ PopT (NameStart) ;
EndScope
END
END PCBuildProcedureHeading ;
@@ -710,7 +710,7 @@ END PCBuildProcedureHeading ;
PROCEDURE BuildNulName ;
BEGIN
- PushT(NulName)
+ PushT (NulName)
END BuildNulName ;
@@ -1121,22 +1121,22 @@ BEGIN
IF IsProcedure(p)
THEN
tok := GetTokenNo () ;
- t := MakeProcType(tok, CheckAnonymous(NulName)) ;
+ t := MakeProcType (tok, CheckAnonymous (NulName)) ;
i := 1 ;
n := NoOfParam(p) ;
WHILE i<=n DO
- par := GetParam(p, i) ;
- IF IsParameterVar(par)
+ par := GetParam (p, i) ;
+ IF IsParameterVar (par)
THEN
- PutProcTypeVarParam(t, GetType(par), IsParameterUnbounded(par))
+ PutProcTypeVarParam (t, GetType (par), IsParameterUnbounded (par))
ELSE
- PutProcTypeParam(t, GetType(par), IsParameterUnbounded(par))
+ PutProcTypeParam (t, GetType (par), IsParameterUnbounded (par))
END ;
INC(i)
END ;
- IF GetType(p)#NulSym
+ IF GetType (p) # NulSym
THEN
- PutFunction(t, GetType(p))
+ PutFunction (t, GetType (p))
END ;
RETURN( t )
ELSE
@@ -1408,11 +1408,12 @@ END buildConstFunction ;
PROCEDURE PushConstFunctionType ;
VAR
- func: CARDINAL ;
- n : CARDINAL ;
+ functok,
+ func : CARDINAL ;
+ n : CARDINAL ;
BEGIN
- PopT(n) ;
- PopT(func) ;
+ PopT (n) ;
+ PopTtok (func, functok) ;
IF inDesignator
THEN
IF (func#Convert) AND
@@ -1420,7 +1421,7 @@ BEGIN
IsPseudoSystemFunctionConstExpression(func) OR
(IsProcedure(func) AND IsProcedureBuiltin(func)))
THEN
- buildConstFunction(func, n)
+ buildConstFunction (func, n)
ELSIF IsAModula2Type(func)
THEN
IF n=1
@@ -1433,13 +1434,17 @@ BEGIN
ELSE
IF Iso
THEN
- WriteFormat0('the only functions permissible in a constant expression are: CAP, CHR, CMPLX, FLOAT, HIGH, IM, LENGTH, MAX, MIN, ODD, ORD, RE, SIZE, TSIZE, TRUNC, VAL and gcc builtins')
+ MetaErrorT1 (functok,
+ 'the only functions permissible in a constant expression are: CAP, CHR, CMPLX, FLOAT, HIGH, IM, LENGTH, MAX, MIN, ODD, ORD, RE, SIZE, TSIZE, TRUNC, VAL and gcc builtins, but not {%1Ead}',
+ func)
ELSE
- WriteFormat0('the only functions permissible in a constant expression are: CAP, CHR, FLOAT, HIGH, MAX, MIN, ODD, ORD, SIZE, TSIZE, TRUNC, VAL and gcc builtins')
+ MetaErrorT1 (functok,
+ 'the only functions permissible in a constant expression are: CAP, CHR, FLOAT, HIGH, MAX, MIN, ODD, ORD, SIZE, TSIZE, TRUNC, VAL and gcc builtins, but not {%1Ead}',
+ func)
END
END
END ;
- PushT(func)
+ PushTtok (func, functok)
END PushConstFunctionType ;
diff --git a/gcc/testsuite/gm2/iso/fail/realbitscast.mod b/gcc/testsuite/gm2/iso/fail/realbitscast.mod
index 8e0e8dc3387..f845630ca46 100644
--- a/gcc/testsuite/gm2/iso/fail/realbitscast.mod
+++ b/gcc/testsuite/gm2/iso/fail/realbitscast.mod
@@ -17,7 +17,7 @@ Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. *)
MODULE realbitscast;
-FROM SYSTEM IMPORT CAST, WORD ;
+FROM SYSTEM IMPORT WORD, CAST ;
TYPE
BITS32 = SET OF [0..31];
@@ -35,6 +35,6 @@ VAR
BEGIN
r32 := 1.0 ;
r64 := 1.0 ;
- b32 := CAST(BITS32, r64) ; (* error (r32), but the compiler should not crash! *)
- b64 := CAST(BITS64, r32) ; (* error (r64), but the compiler should not crash! *)
+ b32 := CAST (BITS32, r64) ; (* error (r32), but the compiler should not crash! *)
+ b64 := CAST (BITS64, r32) ; (* error (r64), but the compiler should not crash! *)
END realbitscast.
reply other threads:[~2022-12-01 22:02 UTC|newest]
Thread overview: [no followups] expand[flat|nested] mbox.gz Atom feed
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20221201220237.610A63858D3C@sourceware.org \
--to=gaius@gcc.gnu.org \
--cc=gcc-cvs@gcc.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).