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 --git a/gcc/m2/gm2-compiler/M2Check.mod b/gcc/m2/gm2-compiler/M2Check.mod
index 20d463d207b8de76a98738f607e79848955fd374..a4451938b88480cbb6c4c2046be12b19dab7d90a 100644 (file)
--- 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 50c2a48fe7ff707eba50b1b711322a8a65981268..4b8e5fadfe7715f9733d40f47ec92f5de226c8e7 100644 (file)
--- 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 ec48631e43fe2fd828fb387b79d710bba42e4938..d7f0f8d943c5cadcee83a4dcdef2ffb97e311e0c 100644 (file)
--- 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 13ee1fb6fe3af9c6083411a4219337d784e4aaa4..7543bb52749725d12f4e6b535774b58ba806f20a 100644 (file)
--- 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 (file)
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 (file)
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 e249ded56082320dadcd4492de7588ca02506a18..0f6cf4b6977cb1337eecead92a8f9d5944cbaf26 100644 (file)
--- 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 4518022dab7aa35d910cb14b7510800150e6d52c..3042c28833daec1ad537d77c9e6116c0242f27db 100644 (file)
--- 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.