From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: by sourceware.org (Postfix, from userid 1499) id 610A63858D3C; Thu, 1 Dec 2022 22:02:37 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 610A63858D3C DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1669932157; bh=v4GwhWqFR5BQm7qXgXQVAH9e+x5fzszMeH1fyIIVT1g=; h=From:To:Subject:Date:From; b=U0o5r8Hgb8xaUe/acYnlxKht2O2fr9R/3Ot+4BgsKMkJ86S6JvBP+Q1a+cExpBrVr EuKVVFHZoEiENj+pudc0lWF9xIs/ej91DyEssaDdCiKxf1qXFiihonxscW86Lay3wg Ucw4oYWswpWjsHvChzI3vZS7tPSzHfRRANUN+sQs= Content-Type: text/plain; charset="us-ascii" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit From: Gaius Mulley To: gcc-cvs@gcc.gnu.org Subject: [gcc/devel/modula-2] Bugfix to catch assigning a standard procedure function to a const. X-Act-Checkin: gcc X-Git-Author: Gaius Mulley X-Git-Refname: refs/heads/devel/modula-2 X-Git-Oldrev: 54ea48efe17dd5646bca3f3929d090d49286c208 X-Git-Newrev: 2ed9ad9b914d96eb717a69dace7c9b4461cb0662 Message-Id: <20221201220237.610A63858D3C@sourceware.org> Date: Thu, 1 Dec 2022 22:02:37 +0000 (GMT) List-Id: https://gcc.gnu.org/g:2ed9ad9b914d96eb717a69dace7c9b4461cb0662 commit 2ed9ad9b914d96eb717a69dace7c9b4461cb0662 Author: Gaius Mulley 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 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