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

(* File: RecordExpr.m3                                         *)
(* Last modified on Wed Aug 19 11:43:50 PDT 1992 by kalsow     *)
(*      modified on Wed Nov 28 02:47:43 1990 by muller         *)

MODULE RecordExpr;

IMPORT Expr, ExprRep, Error, Type, Scope, RecordType, Temp, Emit, String;
IMPORT Value, Field, KeywordExpr, RangeExpr, AssignStmt, MBuf;

TYPE
  P = Expr.T OBJECT
        tipe  : Type.T;
        args  : Expr.List;
        map   : Expr.List;
        types : UNTRACED REF ARRAY OF Type.T;
        names : UNTRACED REF ARRAY OF String.T;
        fields: UNTRACED REF ARRAY OF Value.T;
      OVERRIDES
        typeOf       := ExprRep.NoType;
        check        := Check;
        compile      := Compile;
        evaluate     := Fold;
        fprint       := FPrinter;
        write        := ExprRep.NoWriter;
        isEqual      := EqCheck;
        getBounds    := ExprRep.NoBounds;
        isWritable   := ExprRep.IsNever;
        isDesignator := ExprRep.IsNever;
	isZeroes     := IsZeroes;
	note_write   := ExprRep.NotWritable;
	genLiteral   := GenLiteral;
      END;

PROCEDURE New (type: Type.T;  args: Expr.List): Expr.T =
  VAR p: P;
  BEGIN
    p := NEW (P);
    ExprRep.Init (p);
    p.type  := type;
    p.tipe  := type;
    p.args  := args;
    p.map   := NIL;
    p.names := NIL;
    p.fields:= NIL;
    RETURN p;
  END New;

PROCEDURE Is (e: Expr.T): BOOLEAN =
  BEGIN
    RETURN (TYPECODE (e) = TYPECODE (P));
  END Is;

PROCEDURE Qualify (e: Expr.T;  id: String.T;  VAR result: Expr.T): BOOLEAN =
  VAR
    p      : P;
    fields : Scope.T;
    val    : Value.T;
    offset : INTEGER;
    type   : Type.T;
    z      : Expr.T;
    key    : String.T;
    value  : Expr.T;
  BEGIN
    TYPECASE e OF
    | NULL => RETURN FALSE;
    | P(x) => p := x;
    ELSE      RETURN FALSE;
    END;
    IF NOT RecordType.Split (p.tipe, fields) THEN RETURN FALSE END;
    val := Scope.LookUp (fields, id, TRUE);
    IF (val = NIL) THEN RETURN FALSE END;
    Field.SplitX (val, offset, type);
    FOR i := 0 TO LAST (p.args^) DO
      z := p.args[i];
      IF (KeywordExpr.Split (z, key, value)) THEN
        IF (key = id) THEN result := value; RETURN TRUE END;
      ELSIF (i = offset) THEN
        result := z;  RETURN TRUE;
      END;
    END;
    RETURN FALSE;
  END Qualify;

PROCEDURE Check (p: P;  VAR cs: Expr.CheckState) =
  VAR
    n        : INTEGER;
    fields   : Scope.T;
    key      : String.T;
    value, e : Expr.T;
    posOK    : BOOLEAN;
    objs     : Scope.ValueList;
    offset   : INTEGER;
    type     : Type.T;
    dfault   : Expr.T;
    done     : REF ARRAY OF BOOLEAN;
    fnames   : Scope.NameList;
  BEGIN
    Type.Check (p.tipe);
    FOR i := 0 TO LAST (p.args^) DO Expr.TypeCheck (p.args[i], cs) END;
    p.type := p.tipe;
    IF NOT RecordType.Split (p.tipe, fields) THEN
      Error.Msg ("record constructor must specify a record type");
      RETURN;
    END;
    Scope.ToListWithAliases (fields, objs, n, fnames);
    done := NEW (REF ARRAY OF BOOLEAN, n);
    p.types  := NEW (UNTRACED REF ARRAY OF Type.T, n);
    p.names  := NEW (UNTRACED REF ARRAY OF String.T, n);
    p.fields := NEW (UNTRACED REF ARRAY OF Value.T, n);
    p.map := NEW (Expr.List, n);
    FOR i := 0 TO n - 1 DO
      done[i] := FALSE;
      Field.SplitX (objs[i], offset, type);
      p.fields[offset] := objs[i];
      p.types[offset]  := type;
      p.map[offset]    := Field.GetDefault (objs[i]);
      IF (fnames = NIL)
        THEN p.names[offset] := Value.CName (objs[i]);
        ELSE p.names[offset] := fnames[i];
      END;
    END;
    posOK := TRUE;
    EVAL Fold (p);  (* make sure that the everything that can be folded is *)

    FOR i := 0 TO LAST (p.args^) DO
      e := p.args[i];
      IF RangeExpr.Split (e, value, dfault) THEN
        Error.Msg ("range expressions not allowed in record constructors");
      END;

      IF KeywordExpr.Split (e, key, value) THEN
        posOK := FALSE;
        offset := 0;
        e := value;
        LOOP
          IF (offset >= n) THEN
            Error.Str (key, "unknown field");
            offset := i;
            EXIT;
          END;
          IF (p.names[offset] = key) THEN EXIT END;
          INC (offset);
        END;
      ELSE (* positional parameter *)
        IF (NOT posOK) THEN
          Error.Msg ("positional values must precede keyword values");
        END;
        IF (i >= n)
	  THEN  Error.Msg ("too many values");  offset := n - 1;
          ELSE  offset := i;
        END;
      END;

      IF (0 <= offset) AND (offset < n) THEN
        IF (done[offset]) THEN
          Error.Str (p.names[offset], "field already specified");
        END;
        done[offset] := TRUE;
        IF NOT Type.IsAssignable (p.types[offset], Expr.TypeOf (e)) THEN
          Error.Str (p.names[offset], "expression is not assignable to field");
        ELSE
          p.map[offset] := AssignStmt.CheckRHS (p.types[offset], e, cs);
        END;
      ELSE
        (* some other error, so don't even try *)
      END;
    END;

    FOR i := 0 TO n - 1 DO
      IF (NOT done[i]) AND (p.map[i] = NIL) THEN
        Error.Str (p.names[i], "no value specified for field");
      END;
    END;
  END Check;

PROCEDURE EqCheck (a: P;  e: Expr.T): BOOLEAN =
  VAR b: P;
  BEGIN
    TYPECASE e OF
    | NULL => RETURN FALSE;
    | P(p) => b := p;
    ELSE      RETURN FALSE;
    END;
    IF (NOT Type.IsEqual (a.tipe, b.tipe, NIL))
      OR ((a.args = NIL) # (b.args = NIL))
      OR ((a.args # NIL) AND (NUMBER (a.args^) # NUMBER (b.args^))) THEN
      RETURN FALSE;
    END;
    FOR i := 0 TO LAST (a.args^) DO
      IF NOT Expr.IsEqual (a.args[i], b.args[i]) THEN RETURN FALSE END;
    END;
    RETURN TRUE;
  END EqCheck;

PROCEDURE Compile (p: P): Temp.T =
  VAR t1, t2: Temp.T;  fname: String.T;
  BEGIN
    Type.Compile (p.tipe);
    t1 := Temp.Alloc (p);
    FOR i := 0 TO LAST (p.map^) DO
      fname := Value.CName (p.fields[i]);
      t2 := Expr.Compile (p.map[i]);
      Emit.OpT ("@.", t1);
      Emit.OpS ("@ = ", fname); (* BUG? do a full assignment? *)
      IF Type.Name (p.types[i]) # Type.Name (Expr.TypeOf (p.map[i])) THEN
        Emit.OpF ("(@) ", p.types[i]); 
      END;
      Emit.OpT ("@;\n", t2);
      Temp.Free (t2);
    END;
    RETURN t1;
  END Compile;

PROCEDURE Fold (p: P): Expr.T =
  VAR result := p;
  BEGIN
    FOR i := 0 TO LAST (p.args^) DO
      WITH e = Expr.ConstValue (p.args[i]) DO
        IF (e = NIL) THEN result := NIL; ELSE p.args[i] := e; END;
      END;
    END;
    RETURN result;
  END Fold;

PROCEDURE FPrinter (p: P;  map: Type.FPMap;  wr: MBuf.T) =
  BEGIN
    Type.Fingerprint (p.tipe, map, wr);
    FOR i := 0 TO LAST (p.map^) DO
      Expr.Fingerprint (p.map[i], map, wr);
    END;
  END FPrinter;

PROCEDURE IsZeroes (p: P): BOOLEAN =
  BEGIN
    <* ASSERT p.map # NIL *> (* must already be checked *)
    FOR i := 0 TO LAST (p.map^) DO
      IF NOT Expr.IsZeroes (p.map[i]) THEN RETURN FALSE END;
    END;
    RETURN TRUE;
  END IsZeroes;

PROCEDURE GenLiteral (p: P) =
  VAR last: INTEGER;
  BEGIN
    <* ASSERT p.map # NIL *> (* must already be checked *)
    last := LAST (p.map^);
    WHILE (last > 0) AND (Expr.IsZeroes (p.map[last])) DO DEC (last) END;
    IF (last >= 0) THEN
      Emit.Op ("{\001\n");
      FOR i := 0 TO last DO
        IF (i # 0) THEN Emit.Op (",\n") END;
        WITH e = Expr.ConstValue (p.map[i]) DO
	  <* ASSERT e # NIL *>
          p.map[i] := e;
          Expr.GenLiteral (e);
        END;
      END;
      Emit.Op ("\n\002}");
    END;
  END GenLiteral;

BEGIN
END RecordExpr.