public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc r14-10053] PR modula2/112893 full type checking between proctype and procedure not implemented
@ 2024-04-20 13:36 Gaius Mulley
0 siblings, 0 replies; only message in thread
From: Gaius Mulley @ 2024-04-20 13:36 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:f9a48fe7032d9894e88d0d121ba6f75b08ea5dcb
commit r14-10053-gf9a48fe7032d9894e88d0d121ba6f75b08ea5dcb
Author: Gaius Mulley <gaiusmod2@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 <gaiusmod2@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.
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2024-04-20 13:36 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2024-04-20 13:36 [gcc r14-10053] PR modula2/112893 full type checking between proctype and procedure not implemented Gaius Mulley
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).