https://gcc.gnu.org/g:f9a48fe7032d9894e88d0d121ba6f75b08ea5dcb
commit r14-10053-gf9a48fe7032d9894e88d0d121ba6f75b08ea5dcb Author: Gaius Mulley <gaiusm...@gmail.com> Date: Sat Apr 20 14:35:18 2024 +0100 PR modula2/112893 full type checking between proctype and procedure not implemented This patch implements full type checking between proctype and procedures. The change implements an associated proc type built for each procedure. M2Check.mod will request GetProcedureProcType if it encounters a procedure. Before this patch a procedure was associated with the type ADDRESS in the type checking module M2Check. The gm2/pim/pass/proccard.mod have been corrected now this assumption has been removed. gcc/m2/ChangeLog: PR modula2/112893 * gm2-compiler/M2Check.mod (GetProcedureProcType): Import. (getType): Return value using GetProcedureProcType if sym is a procedure. * gm2-compiler/M2Range.mod (FoldTypeExpr): Remove quad if expression is type compatible. * gm2-compiler/SymbolTable.def (GetProcedureProcType): New procedure function. * gm2-compiler/SymbolTable.mod (Procedure): Add ProcedureType. (MakeProcedure): Initialize ProcedureType. (PutParam): Call AddProcedureProcTypeParam. (PutVarParam): Call AddProcedureProcTypeParam. (AddProcedureProcTypeParam): New procedure. (GetProcedureProcType): New procedure function. gcc/testsuite/ChangeLog: PR modula2/112893 * gm2/pim/pass/another.mod: Correct bug exposed by type checker. Swap ProcA and ProcB assignments. * gm2/pim/pass/proccard.mod: Use VAL to convert procedure into a cardinal. * gm2/iso/const/fail/castproctype.mod: New test. * gm2/pim/fail/badproctype.mod: New test. Signed-off-by: Gaius Mulley <gaiusm...@gmail.com> Diff: --- gcc/m2/gm2-compiler/M2Check.mod | 4 +- gcc/m2/gm2-compiler/M2Range.mod | 3 +- gcc/m2/gm2-compiler/SymbolTable.def | 7 +++ gcc/m2/gm2-compiler/SymbolTable.mod | 76 ++++++++++++++++++++--- gcc/testsuite/gm2/iso/const/fail/castproctype.mod | 19 ++++++ gcc/testsuite/gm2/pim/fail/badproctype.mod | 37 +++++++++++ gcc/testsuite/gm2/pim/pass/another.mod | 8 +-- gcc/testsuite/gm2/pim/pass/proccard.mod | 3 +- 8 files changed, 141 insertions(+), 16 deletions(-) diff --git a/gcc/m2/gm2-compiler/M2Check.mod b/gcc/m2/gm2-compiler/M2Check.mod index 20d463d207b..a4451938b88 100644 --- a/gcc/m2/gm2-compiler/M2Check.mod +++ b/gcc/m2/gm2-compiler/M2Check.mod @@ -47,7 +47,7 @@ FROM SymbolTable IMPORT NulSym, IsRecord, IsSet, GetDType, GetSType, IsType, IsReallyPointer, IsPointer, IsParameter, ModeOfAddr, GetMode, GetType, IsUnbounded, IsComposite, IsConstructor, IsParameter, IsConstString, IsConstLitInternal, IsConstLit, - GetStringLength ; + GetStringLength, GetProcedureProcType ; FROM M2GCCDeclare IMPORT GetTypeMin, GetTypeMax ; FROM M2System IMPORT Address ; @@ -1397,7 +1397,7 @@ PROCEDURE getType (sym: CARDINAL) : CARDINAL ; BEGIN IF (sym # NulSym) AND IsProcedure (sym) THEN - RETURN Address + RETURN GetProcedureProcType (sym) ELSIF IsTyped (sym) THEN RETURN GetDType (sym) diff --git a/gcc/m2/gm2-compiler/M2Range.mod b/gcc/m2/gm2-compiler/M2Range.mod index 50c2a48fe7f..4b8e5fadfe7 100644 --- a/gcc/m2/gm2-compiler/M2Range.mod +++ b/gcc/m2/gm2-compiler/M2Range.mod @@ -1719,7 +1719,8 @@ BEGIN 'expression of type {%1Etad} is incompatible with type {%2tad}', left, right, strict, isin) THEN - SubQuad(q) ; + SubQuad(q) + ELSE setReported (r) END END diff --git a/gcc/m2/gm2-compiler/SymbolTable.def b/gcc/m2/gm2-compiler/SymbolTable.def index ec48631e43f..d7f0f8d943c 100644 --- a/gcc/m2/gm2-compiler/SymbolTable.def +++ b/gcc/m2/gm2-compiler/SymbolTable.def @@ -1394,6 +1394,13 @@ PROCEDURE PutProcedureNoReturn (Sym: CARDINAL; value: BOOLEAN) ; PROCEDURE IsProcedureNoReturn (Sym: CARDINAL) : BOOLEAN ; +(* + GetProcedureProcType - returns the proctype matching procedure sym. +*) + +PROCEDURE GetProcedureProcType (sym: CARDINAL) : CARDINAL ; + + (* 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 13ee1fb6fe3..7543bb52749 100644 --- a/gcc/m2/gm2-compiler/SymbolTable.mod +++ b/gcc/m2/gm2-compiler/SymbolTable.mod @@ -407,6 +407,7 @@ TYPE SavePriority : BOOLEAN ; (* Does procedure need to save *) (* and restore interrupts? *) ReturnType : CARDINAL ; (* Return type for function. *) + ProcedureType : CARDINAL ; (* Proc type for this procedure. *) Offset : CARDINAL ; (* Location of procedure used *) (* in Pass 2 and if procedure *) (* is a syscall. *) @@ -3972,6 +3973,8 @@ BEGIN SavePriority := FALSE ; (* Does procedure need to save *) (* and restore interrupts? *) ReturnType := NulSym ; (* Not a function yet! *) + (* The ProcType equivalent. *) + ProcedureType := MakeProcType (tok, NulName) ; Offset := 0 ; (* Location of procedure. *) InitTree(LocalSymbols) ; InitList(EnumerationScopeList) ; @@ -3993,7 +3996,7 @@ BEGIN := InitValue() ; (* size of all parameters. *) Begin := 0 ; (* token number for BEGIN *) End := 0 ; (* token number for END *) - InitWhereDeclaredTok(tok, At) ; (* Where symbol declared. *) + InitWhereDeclaredTok(tok, At) ; (* Where the symbol was declared. *) errorScope := GetCurrentErrorScope () ; (* Title error scope. *) END END ; @@ -10095,8 +10098,11 @@ BEGIN CASE SymbolType OF ErrorSym: | - ProcedureSym: CheckOptFunction(Sym, FALSE) ; Procedure.ReturnType := TypeSym | - ProcTypeSym : CheckOptFunction(Sym, FALSE) ; ProcType.ReturnType := TypeSym + ProcedureSym: CheckOptFunction(Sym, FALSE) ; + Procedure.ReturnType := TypeSym ; + PutFunction (Procedure.ProcedureType, TypeSym) | + ProcTypeSym : CheckOptFunction(Sym, FALSE) ; + ProcType.ReturnType := TypeSym ELSE InternalError ('expecting a Procedure or ProcType symbol') @@ -10113,13 +10119,16 @@ PROCEDURE PutOptFunction (Sym: CARDINAL; TypeSym: CARDINAL) ; VAR pSym: PtrToSymbol ; BEGIN - pSym := GetPsym(Sym) ; + pSym := GetPsym (Sym) ; WITH pSym^ DO CASE SymbolType OF ErrorSym: | - ProcedureSym: CheckOptFunction(Sym, TRUE) ; Procedure.ReturnType := TypeSym | - ProcTypeSym : CheckOptFunction(Sym, TRUE) ; ProcType.ReturnType := TypeSym + ProcedureSym: CheckOptFunction (Sym, TRUE) ; + Procedure.ReturnType := TypeSym ; + PutOptFunction (Procedure.ProcedureType, TypeSym) | + ProcTypeSym : CheckOptFunction (Sym, TRUE) ; + ProcType.ReturnType := TypeSym ELSE InternalError ('expecting a Procedure or ProcType symbol') @@ -10215,7 +10224,8 @@ BEGIN pSym := GetPsym(ParSym) ; pSym^.Param.ShadowVar := VariableSym END - END + END ; + AddProcedureProcTypeParam (Sym, ParamType, isUnbounded, FALSE) END ; RETURN( TRUE ) END PutParam ; @@ -10268,6 +10278,7 @@ BEGIN pSym^.VarParam.ShadowVar := VariableSym END END ; + AddProcedureProcTypeParam (Sym, ParamType, isUnbounded, TRUE) ; RETURN( TRUE ) END END PutVarParam ; @@ -10345,6 +10356,36 @@ BEGIN END AddParameter ; +(* + AddProcedureProcTypeParam - adds ParamType to the parameter ProcType + associated with procedure Sym. +*) + +PROCEDURE AddProcedureProcTypeParam (Sym, ParamType: CARDINAL; + isUnbounded, isVarParam: BOOLEAN) ; +VAR + pSym: PtrToSymbol ; +BEGIN + pSym := GetPsym (Sym) ; + WITH pSym^ DO + CASE SymbolType OF + + ProcedureSym: IF isVarParam + THEN + PutProcTypeVarParam (Procedure.ProcedureType, + ParamType, isUnbounded) + ELSE + PutProcTypeParam (Procedure.ProcedureType, + ParamType, isUnbounded) + END + + ELSE + InternalError ('expecting Sym to be a procedure') + END + END +END AddProcedureProcTypeParam ; + + (* IsVarParam - Returns a conditional depending whether parameter ParamNo is a VAR parameter. @@ -12623,6 +12664,27 @@ BEGIN END PutProcTypeVarParam ; +(* + GetProcedureProcType - returns the proctype matching procedure sym. +*) + +PROCEDURE GetProcedureProcType (sym: CARDINAL) : CARDINAL ; +VAR + pSym: PtrToSymbol ; +BEGIN + pSym := GetPsym(sym) ; + WITH pSym^ DO + CASE SymbolType OF + + ProcedureSym: RETURN Procedure.ProcedureType + + ELSE + InternalError ('expecting Procedure symbol') + END + END +END GetProcedureProcType ; + + (* PutProcedureReachable - Sets the procedure, Sym, to be reachable by the main Module. diff --git a/gcc/testsuite/gm2/iso/const/fail/castproctype.mod b/gcc/testsuite/gm2/iso/const/fail/castproctype.mod new file mode 100644 index 00000000000..eb66513d874 --- /dev/null +++ b/gcc/testsuite/gm2/iso/const/fail/castproctype.mod @@ -0,0 +1,19 @@ +MODULE castproctype ; + +IMPORT SYSTEM ; + +TYPE + foo3 = PROCEDURE (CARDINAL, INTEGER, CHAR) ; + foo2 = PROCEDURE (CARDINAL, INTEGER) ; + +CONST + bar = SYSTEM.CAST (foo2, NIL) ; + +VAR + p2: foo2 ; + p3: foo3 ; +BEGIN + IF p2 = p3 + THEN + END +END castproctype. diff --git a/gcc/testsuite/gm2/pim/fail/badproctype.mod b/gcc/testsuite/gm2/pim/fail/badproctype.mod new file mode 100644 index 00000000000..1921a8e2785 --- /dev/null +++ b/gcc/testsuite/gm2/pim/fail/badproctype.mod @@ -0,0 +1,37 @@ +MODULE badproctype ; + +TYPE + MYSHORTREAL = REAL; + +TYPE + PROCA = PROCEDURE (VAR ARRAY OF REAL); + PROCB = PROCEDURE (VAR ARRAY OF MYSHORTREAL); + +VAR + pa: PROCA; pb: PROCB; + x: ARRAY [0..1] OF REAL; + y: ARRAY [0..1] OF MYSHORTREAL; + +PROCEDURE ProcA(VAR z: ARRAY OF REAL); +BEGIN +END ProcA ; + +PROCEDURE ProcB(VAR z: ARRAY OF MYSHORTREAL); +BEGIN +END ProcB ; + +BEGIN + x := y; + pa := ProcA; + pb := ProcB; + pa(x); + pa(y); + pb(x); + pb(y); + pa := ProcB; (* proctype does not match. *) + pb := ProcA; (* proctype does not match. *) + pa(x); + pa(y); + pb(x); + pb(y) +END badproctype. diff --git a/gcc/testsuite/gm2/pim/pass/another.mod b/gcc/testsuite/gm2/pim/pass/another.mod index e249ded5608..0f6cf4b6977 100644 --- a/gcc/testsuite/gm2/pim/pass/another.mod +++ b/gcc/testsuite/gm2/pim/pass/another.mod @@ -2,7 +2,7 @@ MODULE another ; TYPE MYSHORTREAL = REAL; - + TYPE PROCA = PROCEDURE (VAR ARRAY OF REAL); PROCB = PROCEDURE (VAR ARRAY OF MYSHORTREAL); @@ -11,7 +11,7 @@ VAR pa: PROCA; pb: PROCB; x: ARRAY [0..1] OF REAL; y: ARRAY [0..1] OF MYSHORTREAL; - + PROCEDURE ProcA(VAR z: ARRAY OF REAL); BEGIN END ProcA ; @@ -28,8 +28,8 @@ BEGIN pa(y); pb(x); pb(y); - pa := ProcB; - pb := ProcA; + pa := ProcA; + pb := ProcB; pa(x); pa(y); pb(x); diff --git a/gcc/testsuite/gm2/pim/pass/proccard.mod b/gcc/testsuite/gm2/pim/pass/proccard.mod index 4518022dab7..3042c28833d 100644 --- a/gcc/testsuite/gm2/pim/pass/proccard.mod +++ b/gcc/testsuite/gm2/pim/pass/proccard.mod @@ -8,7 +8,6 @@ BEGIN RETURN 42 END func ; - BEGIN - WriteString ('the value is: ') ; WriteCard (func, 5) ; WriteLn + WriteString ('the value is: ') ; WriteCard (VAL (CARDINAL, func), 5) ; WriteLn END proccard.