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

(* File: OpenArrayType.m3                                      *)
(* Last modified on Wed Sep  2 10:47:10 PDT 1992 by rustan     *)
(*      modified on Mon Feb 24 15:11:34 PST 1992 by kalsow     *)
(*      modified on Sun Feb 24 04:39:01 1991 by muller         *)

MODULE OpenArrayType;

IMPORT Type, TypeRep, Error, Emit, Target, MBuf, String, Word;
IMPORT PackedType, Frame, ArrayType;
IMPORT TrOffsets;

TYPE
  P = Type.T BRANDED "OpenArrayType.P" OBJECT
        element    : Type.T;
        baseElt    : Type.T;
        depth      : INTEGER;
      OVERRIDES
        check      := Check;
        base       := TypeRep.SelfBase;
        isEqual    := EqualChk;
        isSubtype  := Subtyper;
        count      := TypeRep.NotOrdinal;
        bounds     := TypeRep.NotBounded;
        size       := Sizer;
        minSize    := Sizer;
        alignment  := Aligner;
	isEmpty    := IsEmpty;
        dependsOn  := DependsOn;
        compile    := Compiler;
        initCost   := InitCoster;
        initValue  := GenInit;
        tracedOffs := TracedOffs;
        paramEncoding := TypeRep.ParamEncUndefined;
        mapper     := GenMap;
        fprint     := FPrinter;
        class      := MyClass;
      END;

PROCEDURE New (element: Type.T): Type.T =
  VAR p: P;
  BEGIN
    p := NEW (P);
    TypeRep.Init (p);
    p.element    := element;
    p.baseElt    := NIL;
    p.depth      := -1;
    RETURN p;
  END New;

PROCEDURE Is (t: Type.T): BOOLEAN =
  VAR p: P;
  BEGIN
    RETURN Reduce (t, p);
  END Is;

PROCEDURE Split (t: Type.T;  VAR element: Type.T): BOOLEAN =
  VAR p: P;
  BEGIN
    IF NOT Reduce (t, p) THEN RETURN FALSE END;
    element := p.element;
    RETURN TRUE;
  END Split;

PROCEDURE OpenDepth (t: Type.T): INTEGER =
  VAR p: P;
  BEGIN
    IF NOT Reduce (t, p) THEN RETURN 0 END;
    IF (p.depth <= 0) THEN  p.depth := 1 + OpenDepth (p.element)  END;
    RETURN p.depth;
  END OpenDepth;

PROCEDURE OpenType (t: Type.T): Type.T =
  VAR p: P;
  BEGIN
    IF NOT Reduce (t, p) THEN RETURN t END;
    IF (p.baseElt = NIL) THEN  p.baseElt := OpenType (p.element)  END;
    RETURN p.baseElt;
  END OpenType;

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

PROCEDURE Check (p: P) =
  VAR bits: INTEGER;  eltelt: Type.T;
  BEGIN
    Type.Check (p.element);
    IF PackedType.Split (p.element, bits, eltelt) THEN
      IF (bits # Type.Size (eltelt)) THEN
        Error.Msg ("SRC Modula-3 does not support this type");
      END;
    END;

    p.isTraced := Type.IsTraced (p.element);
    p.hasUntraced := Type.HasUntraced (p.element);
    p.isLocalOnly := TRUE;
    p.hash := Word.Times (23, OpenDepth (p));
    p.hash := Word.Plus (p.hash, Word.Times (37, Type.Size (p.element)));
  END Check;

PROCEDURE Compiler (p: P) =
  BEGIN
    Type.Compile (p.element);
    IF TypeRep.IsCompiled (p) THEN RETURN END;
    GenDecl (p);

    IF TypeRep.StartLinkInfo (p) THEN RETURN END;

    Emit.OpF ("d@\n", OpenType (p));

    Emit.Op  ("C\n");
    GenDecl (p);
    Emit.Op  ("*\n");
  END Compiler;

PROCEDURE GenDecl (p: P) =
  BEGIN
    Emit.OpFF ("struct _array@ { @ *elts; ", p, OpenType (p));
    Emit.OpI  ("int size[@]; };\n", OpenDepth (p));
    Emit.OpFF ("typedef struct _array@ @;\n", p, p);
  END GenDecl;

PROCEDURE EqualChk (a: P;  t: Type.T;  x: Type.Assumption): BOOLEAN =
  VAR b: P;
  BEGIN
    RETURN Reduce (t, b)
       AND (OpenDepth (a) = OpenDepth (b))
       AND Type.IsEqual (a.element, b.element, x);
  END EqualChk;

PROCEDURE Subtyper (a: P;  tb: Type.T): BOOLEAN =
  VAR ta, ia, ea, ib, eb: Type.T;  b: P;
  BEGIN
    ta := a;

    (* peel off the common open dimensions *)
    WHILE Reduce (ta, a) AND Reduce (tb, b) DO
      ta := a.element;
      tb := b.element;
    END;

    (* peel off the remaining fixed dimensions of A and open dimensions of B *)
    WHILE ArrayType.Split (ta, ia, ea) AND Reduce (tb, b) DO
      ta := ea;
      tb := b.element;
    END;

    (* peel off the fixed dimensions as long as the sizes are equal *)
    WHILE ArrayType.Split (ta, ia, ea) AND ArrayType.Split (tb, ib, eb) DO
      IF Type.Number (ia) # Type.Number (ib) THEN RETURN FALSE END;
      ta := ea;
      tb := eb;
    END;

    RETURN Type.IsEqual (ta, tb, NIL);
  END Subtyper;

<*INLINE*> PROCEDURE Reduce (t: Type.T;  VAR p: P): BOOLEAN =
  BEGIN
    TYPECASE Type.Strip (t) OF
    | NULL => RETURN FALSE;
    | P(x) => p := x;  RETURN TRUE;
    ELSE      RETURN FALSE;
    END;
  END Reduce;

PROCEDURE Sizer (<*UNUSED*>p: P): INTEGER =
  BEGIN
    RETURN -1;
  END Sizer;

PROCEDURE Aligner (p: P): INTEGER =
  BEGIN
    RETURN MAX (MAX (Type.Alignment (p.element), Target.STRUCTURESIZEBOUNDARY),
                MAX (Target.ADDRALIGN, Target.INTALIGN));
  END Aligner;

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

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

PROCEDURE InitCoster (p: P; zeroed: BOOLEAN): INTEGER =
  VAR n, m: INTEGER;
  BEGIN
    m := Type.InitCost (p.element, zeroed);
    n := 20;  (* guess that there are 20 elements *)
    m := MIN (Target.MAXINT DIV n, m);
    RETURN n * m;
  END InitCoster;

PROCEDURE GenInit (<*UNUSED*> p: P) =
  BEGIN
    <* ASSERT FALSE *>
  END GenInit;

PROCEDURE TracedOffs (p: P;  offset: CARDINAL): TrOffsets.T =
  VAR eltType: Type.T;
  BEGIN
    <* ASSERT offset = 0 *>
    eltType := OpenType (p);
    RETURN Type.TracedOffsets (eltType, offset)
  END TracedOffs;

VAR bptr, cptr: String.T := NIL;

PROCEDURE GenMap (p: P;  VAR prefix: String.Stack) =
  VAR nDims, block: INTEGER;  newPrefix: String.Stack;  eltType: Type.T;
  BEGIN
    IF Type.IsTraced (p.element) OR Type.HasUntraced (p.element) THEN
      IF (cptr = NIL) THEN cptr := String.Add ("_aptr[_i") END;
      IF (bptr = NIL) THEN bptr := String.Add ("]"); END;
      eltType := OpenType (p);
      nDims := OpenDepth (p);
      Frame.PushBlock (block, 3);
      Emit.OpI ("int _i@, _j;\n", prefix.top);
      Emit.OpF ("@* _zz;\n", p);
      Emit.OpF ("@* _aptr;\n", eltType);
      Emit.OpZ ("_zz = & (@);\n", prefix);
      Emit.Op  ("_j = ");
      FOR i := 0 TO nDims-1 DO
        IF (i # 0) THEN Emit.Op (" * ") END;
        Emit.OpI ("_zz->size[@]", i);
      END;
      Emit.Op (";\n");
      Emit.OpF ("_aptr = (@*) _zz->elts;\n", eltType);
      Emit.OpI ("for (_i@ = 0; ", prefix.top);
      Emit.OpI ("_i@ < _j; ", prefix.top);
      Emit.OpI ("_i@++) {\001\n", prefix.top);
      newPrefix.stk [0] := cptr;
      newPrefix.stk [1] := String.AddInt (prefix.top);
      newPrefix.stk [2] := bptr;
      newPrefix.top := 3;
      Type.GenMap (eltType, newPrefix);
      Emit.Op ("\002}\n");
      Frame.PopBlock (block);
    END;
  END GenMap;

PROCEDURE FPrinter (p: P;  map: Type.FPMap;  wr: MBuf.T) =
  BEGIN
    MBuf.PutText (wr, "ARRAY * ");
    Type.Fingerprint (p.element, map, wr);
  END FPrinter;

BEGIN
END OpenArrayType.