gpcp/Visitor.cp

   1 (* ==================================================================== *)
   2 (*                                                                      *)
   3 (*  Visitor pattern for the Gardens Point Component Pascal Compiler.    *)
   4 (*  This module defines various extensions of type Symbols.SymForAll    *)
   5 (*  Copyright (c) John Gough 1999, 2000.                                *)
   6 (*                                                                      *)
   7 (* ==================================================================== *)
   8
   9 MODULE Visitor;
  10
  11   IMPORT
  12         GPCPcopyright,
  13         Console,
  14         Symbols,
  15         CPascalS,
  16         LitValue,
  17         Id := IdDesc,
  18         Ty := TypeDesc,
  19         NameHash;
  20
  21 (* ============================================================ *)
  22
  23   TYPE
  24     Resolver* = POINTER TO RECORD (Symbols.SymForAll) END;
  25
  26 (* -------------------------------------------- *)
  27
  28   TYPE
  29     ImplementedCheck* = POINTER TO RECORD (Symbols.SymForAll) END;
  30
  31 (* -------------------------------------------- *)
  32
  33   TYPE
  34     TypeEraser* = POINTER TO RECORD (Symbols.SymForAll) END;
  35
  36 (* -------------------------------------------- *)
  37
  38   TYPE
  39     Accumulator* = POINTER TO RECORD (Symbols.SymForAll)
  40          missing  : Symbols.SymbolTable;
  41          recordTb : Ty.Record;
  42          isIntrfc : BOOLEAN;
  43        END;
  44
  45 (* ============================================================ *)
  46
  47   PROCEDURE newAccumulator(target : Ty.Record) : Accumulator;
  48   (** Create a new symbol table and add to it all of the abstract *)
  49   (*  methods which are not concrete in the target scope space.   *)
  50     VAR tmp : Accumulator;
  51   BEGIN
  52     NEW(tmp);
  53     tmp.recordTb := target;
  54     tmp.isIntrfc := FALSE;  (* not an interface *)
  55     RETURN tmp;
  56   END newAccumulator;
  57
  58  (* --------------------------- *)
  59
  60   PROCEDURE newInterfaceCheck(target : Ty.Record) : Accumulator;
  61   (** Create a new symbol table and add to it all of the abstract *)
  62   (*  methods which are not concrete in the target scope space.   *)
  63     VAR tmp : Accumulator;
  64   BEGIN
  65     NEW(tmp);
  66     tmp.recordTb := target;
  67     tmp.isIntrfc := TRUE; (* is an interface *)
  68     RETURN tmp;
  69   END newInterfaceCheck;
  70
  71  (* --------------------------- *)
  72
  73   PROCEDURE (sfa : Accumulator)Op*(id : Symbols.Idnt);
  74     VAR anyId : Symbols.Idnt;
  75         pType : Ty.Procedure;
  76         junk  : BOOLEAN;
  77   BEGIN
  78     IF id.isAbstract() THEN
  79      (*
  80       *  Lookup the id in the original record name-scope
  81       *  If id implements some interface method, we must
  82       *  force it to be virtual by getting rid of newBit.
  83       *)
  84       anyId := sfa.recordTb.bindField(id.hash);
  85       IF (anyId = NIL) OR anyId.isAbstract() THEN
  86         junk := sfa.missing.enter(id.hash, id);
  87       ELSIF sfa.isIntrfc & (anyId.kind = Id.conMth) THEN
  88         EXCL(anyId(Id.MthId).mthAtt, Id.newBit);
  89         pType := id.type(Ty.Procedure);
  90         pType.CheckCovariance(anyId);
  91         IF id.vMod # anyId.vMod THEN anyId.IdError(163) END;
  92         IF id(Id.Procs).prcNm # NIL THEN
  93             anyId(Id.Procs).prcNm := id(Id.Procs).prcNm END;
  94       END;
  95     END;
  96   END Op;
  97
  98 (* -------------------------------------------- *)
  99
 100   PROCEDURE newImplementedCheck*() : ImplementedCheck;
 101     VAR tmp : ImplementedCheck;
 102   BEGIN NEW(tmp); RETURN tmp END newImplementedCheck;
 103
 104  (* --------------------------- *)
 105
 106   PROCEDURE (sfa : ImplementedCheck)Op*(id : Symbols.Idnt);
 107     VAR acc : Accumulator;
 108         rTp : Ty.Record;
 109         nTp : Ty.Record;
 110         bTp : Symbols.Type;
 111         idx : INTEGER;
 112    (* ----------------------------------------- *)
 113     PROCEDURE InterfaceIterate(r : Ty.Record;
 114              a : Accumulator);
 115       VAR i : INTEGER;
 116           x : Ty.Record;
 117     BEGIN
 118       FOR i := 0 TO r.interfaces.tide - 1 DO
 119         x := r.interfaces.a[i].boundRecTp()(Ty.Record);
 120         x.symTb.Apply(a);
 121         InterfaceIterate(x, a); (* recurse to inherited interfaces *)
 122       END;
 123     END InterfaceIterate;
 124    (* ----------------------------------------- *)
 125   BEGIN
 126     IF id.kind = Id.typId THEN
 127       rTp := id.type.boundRecTp()(Ty.Record);
 128       IF (rTp # NIL) &      (* ==> this is a record type  *)
 129          ~rTp.isAbsRecType() &    (* ==> this rec is NOT abstract *)
 130          ~rTp.isImportedType() &  (* ==> this rec is NOT imported *)
 131          (rTp.baseTp # NIL) THEN  (* ==> this extends some type   *)
 132         bTp := rTp.baseTp;
 133         IF bTp.isAbsRecType() THEN  (* ==> and base _is_ abstract.  *)
 134          (*
 135           *  This is a concrete record extending an abstract record.
 136           *  By now, all inherited abstract methods must have been
 137           *  resolved to concrete methods.  Traverse up the base
 138           *  hierarchy accumulating unimplemented methods.
 139           *)
 140           acc := newAccumulator(rTp);
 141           REPEAT
 142             nTp := bTp(Ty.Record);  (* guaranteed for first time  *)
 143             bTp := nTp.baseTp;
 144             nTp.symTb.Apply(acc);
 145           UNTIL (bTp = NIL) OR bTp.isBaseType();
 146          (*
 147           *  Now we turn the missing table into a list.
 148           *)
 149           IF ~acc.missing.isEmpty() THEN
 150             CPascalS.SemError.RepSt1(121, Symbols.dumpList(acc.missing),
 151             id.token.lin, id.token.col);
 152           END;
 153         END;
 154         IF rTp.interfaces.tide > 0 THEN
 155          (*
 156           *   The record rTp claims to implement interfaces.
 157           *   We must check conformance to the contract.
 158           *)
 159           acc := newInterfaceCheck(rTp);
 160           InterfaceIterate(rTp, acc);
 161          (*
 162           *  Now we turn the missing table into a list.
 163           *)
 164           IF ~acc.missing.isEmpty() THEN
 165             CPascalS.SemError.RepSt1(159, Symbols.dumpList(acc.missing),
 166             id.token.lin, id.token.col);
 167           END;
 168         END;
 169       END;
 170     END;
 171   END Op;
 172
 173 (* -------------------------------------------- *)
 174
 175   PROCEDURE newResolver*() : Resolver;
 176     VAR tmp : Resolver;
 177   BEGIN
 178     NEW(tmp);
 179     RETURN tmp;
 180   END newResolver;
 181
 182  (* --------------------------- *)
 183
 184   PROCEDURE (sfa : Resolver)Op*(id : Symbols.Idnt);
 185     VAR idTp : Symbols.Type;
 186   BEGIN
 187     IF (id.kind = Id.typId) OR (id.kind = Id.varId) THEN
 188       idTp := id.type;
 189       IF idTp # NIL THEN
 190         idTp := idTp.resolve(1);
 191 (* ------------------------------------------------- *
 192  *      IF idTp # NIL THEN
 193  *        WITH idTp : Ty.Array DO
 194  *           IF idTp.isOpenArrType() THEN id.IdError(67) END;
 195  *        | idTp : Ty.Record DO
 196  *           IF id.kind = Id.varId THEN idTp.InstantiateCheck(id.token) END;
 197  *        ELSE
 198  *        END;
 199  *      END;
 200  * ------------------------------------------------- *)
 201         IF (idTp # NIL) & (id.kind = Id.varId) THEN
 202           WITH idTp : Ty.Array DO (* only for varIds, kjg 2004 *)
 203              IF idTp.isOpenArrType() THEN id.IdError(67) END;
 204           | idTp : Ty.Record DO
 205              idTp.InstantiateCheck(id.token);
 206           ELSE
 207           END;
 208         END;
 209 (* ------------------------------------------------- *)
 210       END;
 211       id.type := idTp;
 212     END;
 213   END Op;
 214
 215  (* --------------------------- *)
 216
 217   PROCEDURE newTypeEraser*() : TypeEraser;
 218     VAR tmp : TypeEraser;
 219   BEGIN
 220     NEW(tmp);
 221     RETURN tmp;
 222   END newTypeEraser;
 223
 224  (* --------------------------- *)
 225
 226   PROCEDURE (sfa : TypeEraser)Op*(id : Symbols.Idnt);
 227   (* Erases any compound types found in the symbol table. These
 228    *  are converted to their implementation types *)
 229     VAR idTp : Symbols.Type;
 230         ct   : Ty.Record;
 231   BEGIN
 232     IF id.type # NIL THEN
 233       id.type := id.type.TypeErase();
 234     END;
 235   END Op;
 236
 237 (* ============================================================ *)
 238 END Visitor.  (* ============================================== *)
 239 (* ============================================================ *)
 240