From f9a48fe7032d9894e88d0d121ba6f75b08ea5dcb Mon Sep 17 00:00:00 2001 From: Gaius Mulley Date: Sat, 20 Apr 2024 14:35:18 +0100 Subject: 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 --- 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(-) create mode 100644 gcc/testsuite/gm2/iso/const/fail/castproctype.mod create mode 100644 gcc/testsuite/gm2/pim/fail/badproctype.mod diff --git a/gcc/m2/gm2-compiler/M2Check.mod b/gcc/m2/gm2-compiler/M2Check.mod index 20d463d..a445193 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 50c2a48..4b8e5fa 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 ec48631..d7f0f8d 100644 --- a/gcc/m2/gm2-compiler/SymbolTable.def +++ b/gcc/m2/gm2-compiler/SymbolTable.def @@ -1395,6 +1395,13 @@ 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, Sym. diff --git a/gcc/m2/gm2-compiler/SymbolTable.mod b/gcc/m2/gm2-compiler/SymbolTable.mod index 13ee1fb..7543bb5 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 ; @@ -10346,6 +10357,36 @@ 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. *) @@ -12624,6 +12665,27 @@ 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 0000000..eb66513 --- /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 0000000..1921a8e --- /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 e249ded..0f6cf4b 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 4518022..3042c28 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. -- cgit v1.1