(* Copyright (C) 1992, Digital Equipment Corporation           *)
(* All rights reserved.                                        *)
(* See the file COPYRIGHT for a full description.              *)

(* File: PackedType.m3                                         *)
(* Last modified on Mon Mar  9 14:15:45 PST 1992 by kalsow     *)
(*      modified on Fri Dec 21 01:25:20 1990 by muller         *)

MODULE PackedType;

IMPORT M3, Word, Type, TypeRep, Error, Expr, Scanner, IntegerExpr;
IMPORT Emit, MBuf, Token, EnumType, SubrangeType;
IMPORT ParamCode, Target;

TYPE
  P = Type.T OBJECT
        sizeE      : Expr.T;
        newSize    : INTEGER;
        baseType   : Type.T;
      OVERRIDES
        check      := Check;
        base       := Baser;
        isEqual    := EqualChk;
        isSubtype  := Subtyper;
        count      := Counter;
        bounds     := Bounder;
        size       := Sizer;
        minSize    := Sizer;
        alignment  := Aligner;
	isEmpty    := IsEmpty;
        dependsOn  := DependsOn;
        compile    := Compiler;
        initCost   := InitCoster;
        initValue  := GenInit;
        paramEncoding := ParamEnc;
        mapper     := TypeRep.NoMapper;
        fprint     := FPrinter;
        class      := MyClass;
      END;

PROCEDURE Parse (READONLY fail: Token.Set): Type.T =
  TYPE TK = Token.T;
  VAR p: P;
  BEGIN
    p := New (-1, NIL);
    Scanner.Match (TK.tBITS, fail, Token.Set {TK.tFOR} + Token.TypeStart);
    p.sizeE := Expr.Parse (fail + Token.Set {TK.tFOR} + Token.TypeStart);
    Scanner.Match (TK.tFOR, fail, Token.TypeStart);
    p.baseType := Type.Parse (fail);
    RETURN p;
  END Parse;

PROCEDURE New (size: INTEGER;  base: Type.T): Type.T =
  VAR p: P;
  BEGIN
    p := NEW (P);
    TypeRep.Init (p);
    p.sizeE    := NIL;
    p.newSize  := size;
    p.baseType := base;
    RETURN p;
  END New;

PROCEDURE Split (t: Type.T;  VAR size: INTEGER;  VAR base: Type.T): BOOLEAN =
  BEGIN
    TYPECASE Type.Strip (t) OF
    | NULL => RETURN FALSE;
    | P(p) => size := p.newSize;  base := p.baseType;  RETURN TRUE;
    ELSE      RETURN FALSE;
    END;
  END Split;

PROCEDURE Strip (t: Type.T): Type.T =
  BEGIN
    LOOP
      t := Type.Strip (t);
      TYPECASE t OF
      | NULL => RETURN NIL;
      | P(p) => t := p.baseType;
      ELSE      RETURN t;
      END;
    END;
  END Strip;

PROCEDURE MyClass (<*UNUSED*> p: P): TypeRep.Class =
  BEGIN
    RETURN TypeRep.Class.Packed;
  END MyClass;

PROCEDURE Check (p: P) =
  VAR
    old_sz, new_sz, old_min, align, x, y: INTEGER;
    e: Expr.T;
    cs := M3.OuterCheckState;
  BEGIN
    Type.Check (p.baseType);
    old_sz  := Type.Size (p.baseType);
    old_min := Type.MinSize (p.baseType);
    align   := Type.Alignment (p.baseType);
    new_sz  := old_sz;

    IF (p.sizeE # NIL) THEN
      Expr.TypeCheck (p.sizeE, cs);
      e := Expr.ConstValue (p.sizeE);
      IF (e = NIL) OR NOT IntegerExpr.Split (e, new_sz)
        THEN Error.Msg ("BITS FOR size must be a constant integer");
        ELSE p.sizeE := e;
      END;
    END;

    IF (new_sz < old_min) THEN
      Error.Msg ("BITS FOR size too small");
      new_sz := old_min;
    ELSIF (new_sz # old_sz)
      AND NOT EnumType.Is (p.baseType)
      AND NOT SubrangeType.Split (p.baseType, x, y) THEN
      Error.Msg ("SRC Modula-3 does not support this packed type");
      new_sz := old_sz;
    ELSIF (new_sz > old_sz) AND (new_sz MOD align # 0) THEN
      Error.Msg ("large sizes must be aligned");
      new_sz := old_sz;
    END;

    p.newSize := new_sz;
    p.isTraced := Type.IsTraced (p.baseType);
    p.hasUntraced := Type.HasUntraced (p.baseType);
    p.isLocalOnly := Type.IsLocalOnly (p.baseType);
    p.hash := Word.Plus (Word.Times (61, p.baseType.hash), new_sz);
  END Check;

PROCEDURE Compiler (p: P) =
  BEGIN
    Type.Compile (p.baseType);
    IF TypeRep.IsCompiled (p) THEN RETURN END;
    Emit.OpFF ("\003#define @ @\n", p, p.baseType);

    IF TypeRep.StartLinkInfo (p) THEN RETURN END;

    Emit.OpF  ("d@\n", p.baseType);
    Emit.Op   ("C\n");
    Emit.OpFF ("\003#define @ @\n", p, p.baseType);
    Emit.Op   ("*\n");
  END Compiler;

PROCEDURE Baser (p: P): Type.T =
  BEGIN
    RETURN Type.Base (p.baseType);
  END Baser;

PROCEDURE EqualChk (a: P;  t: Type.T;  x: Type.Assumption): BOOLEAN =
  BEGIN
    TYPECASE Type.Strip (t) OF
    | NULL => RETURN FALSE;
    | P(b) => RETURN (a.newSize = b.newSize)
                 AND Type.IsEqual (a.baseType, b.baseType, x);
    ELSE      RETURN FALSE;
    END;
  END EqualChk;

PROCEDURE Subtyper (a: P;  b: Type.T): BOOLEAN =
  BEGIN
    RETURN Type.IsEqual (Strip (b), Strip (a.baseType), NIL);
  END Subtyper;

PROCEDURE Counter (p: P): INTEGER =
  BEGIN
    RETURN Type.Number (p.baseType);
  END Counter;

PROCEDURE Bounder (p: P;  VAR min, max: INTEGER): BOOLEAN =
  BEGIN
    RETURN Type.GetBounds (p.baseType, min, max);
  END Bounder;

PROCEDURE Sizer (p: P): INTEGER =
  BEGIN
    IF (NOT p.checked) THEN Check (p) END;
    RETURN p.newSize;
  END Sizer;

PROCEDURE Aligner (<*UNUSED*> t: Type.T): INTEGER =
  BEGIN
    RETURN 1;
  END Aligner;

PROCEDURE IsEmpty (p: P): BOOLEAN =
  BEGIN
    RETURN Type.IsEmpty (p.baseType);
  END IsEmpty;

PROCEDURE DependsOn (p: P;  t: Type.T): BOOLEAN =
  BEGIN
    RETURN Type.DependsOn (p.baseType, t);
  END DependsOn;

PROCEDURE InitCoster (p: P;  zeroed: BOOLEAN): INTEGER =
  BEGIN
    RETURN Type.InitCost (p.baseType, zeroed);
  END InitCoster;

PROCEDURE GenInit (p: P) =
  BEGIN
    Type.GenInitialValue (p.baseType);
  END GenInit;

PROCEDURE ParamEnc (p: P): TEXT =
  VAR s := ( Type.Size( p ) + Target.INTSIZE - 1 ) DIV Target.INTSIZE;
      enc: TEXT := "";
  BEGIN
    WHILE s > 0 DO
      enc := enc & ParamCode.Word;  DEC( s )
    END;
    RETURN enc
  END ParamEnc;

PROCEDURE FPrinter (p: P;  map: Type.FPMap;  wr: MBuf.T) =
  BEGIN
    MBuf.PutText (wr, "BITS ");
    MBuf.PutInt  (wr, p.newSize);
    MBuf.PutText (wr, " ");
    Type.Fingerprint (p.baseType, map, wr);
  END FPrinter;

BEGIN
END PackedType.