MODULE M3CNEWNorm;

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

IMPORT M3AST, M3AST_LX, M3AST_AS;

IMPORT M3CStdProcs, M3ASTNext, M3CTypesMisc, M3CTypeSpecS;
IMPORT M3CTmpAtt, M3CEncTypeSpec, M3CSpec, M3CInitExp, M3CDef;

IMPORT SeqM3AST_AS_Actual, SeqM3AST_AS_Override; 

IMPORT M3AST_AS_F, M3AST_SM_F, M3AST_TL_F;

PROCEDURE Set(n: M3AST.NODE; unit_id: M3AST_AS.UNIT_ID) RAISES {}=
  VAR actual: M3AST_AS.Actual;
      ts: M3AST_AS.TYPE_SPEC := NIL;
      ots: M3AST_AS.Object_type := NIL;
  BEGIN
    TYPECASE n OF
    | M3AST_AS.NEWCall(call) =>
        actual := SeqM3AST_AS_Actual.First(call.as_param_s);
        TYPECASE actual.as_exp_type OF
        | M3AST_AS.Object_type(ot) =>
            ts := ot;
        | M3AST_AS.Exp_used_id(exp) =>
            CheckNamedObjectType(exp, ots, ts);
        | M3AST_AS.Binary(b) =>
            IF ISTYPE(b.as_binary_op, M3AST_AS.Select) THEN
              (* For this to be an object type name, then the
                 LHS must be a reference to an Interface_id.
                 However, at this stage the sm_def attribute
                 of the RHS has not been set up and we need this
                 to decide if it is an object type. So we verify
                 the LHS is an Interface_id and explicitly call
                 M3CDef.ResolveInterfaceId to set sm_def of the RHS. 
              *)
              TYPECASE b.as_exp1 OF
              | M3AST_AS.Exp_used_id(e1) =>
                  TYPECASE e1.vUSED_ID.sm_def OF
                  | NULL => (* some other error *)
                  | M3AST_AS.Interface_id(intf_id) =>
                      TYPECASE b.as_exp2 OF
                      | M3AST_AS.Exp_used_id(e2) =>
                          M3CDef.ResolveInterfaceId(intf_id, e2.vUSED_ID);
                          CheckNamedObjectType(e2, ots, ts);
                      ELSE
                      END;
                  ELSE
                  END;
              ELSE
              END;
            END; (* if *)
        ELSE
        END; (* typecase *)
        IF ots # NIL THEN
          CreateOverride(call, ts, ots, unit_id)
        END; (* if *)
    ELSE
    END; (* typecase *)
  END Set;

PROCEDURE CheckNamedObjectType(e: M3AST_AS.Exp_used_id;
    VAR (*out*) ots: M3AST_AS.Object_type;
    VAR (*out*) ts: M3AST_AS.TYPE_SPEC) RAISES {}=
  VAR rts: M3AST_AS.TYPE_SPEC;
  BEGIN
    TYPECASE e.vUSED_ID.sm_def OF
    | M3AST_AS.Type_id(id) =>
        IF id # NIL AND id.sm_type_spec # NIL THEN
           rts := M3CTypesMisc.Reveal(id.sm_type_spec);
           IF ISTYPE(rts, M3AST_AS.Object_type) THEN
             ots := rts;
             ts := id.sm_type_spec;
           END;
        END; (* if *)
     ELSE
     END; (* typecase *)
  END CheckNamedObjectType;


PROCEDURE CreateOverride(
    call: M3AST_AS.NEWCall;
    ts: M3AST_AS.TYPE_SPEC;
    ots: M3AST_AS.Object_type;
    unit_id: M3AST_AS.UNIT_ID)
    RAISES {}=
  VAR
    iter := SeqM3AST_AS_Actual.NewIter(call.as_param_s);
    type, actual, new_actual: M3AST_AS.Actual;
    started := FALSE;
    ov_ot: M3AST_AS.Object_type := NIL;
    ancestor: M3AST_AS.M3TYPE;
    new_param_s := SeqM3AST_AS_Actual.Null;
  BEGIN
    (* 'ts' may equal 'ots', but not if 'ts' was opaque, in which case
       'ots' is the current revelation. It is very important that we create
       a Named_Type with 'ts' rather than 'ots' as the sm_type_spec attribute,
       else type-checking will fail later. 
    *)
    EVAL SeqM3AST_AS_Actual.Next(iter, type);
    WHILE SeqM3AST_AS_Actual.Next(iter, actual) DO
      IF actual.as_id # NIL AND ISTYPE(actual.as_id, M3AST_AS.Exp_used_id) AND
           IsMethod(actual.as_id, ots) AND
           ISTYPE(actual.as_exp_type, M3AST_AS.EXP) THEN
        IF NOT started THEN
          (* create the object type *)
          started := TRUE;
          ov_ot := M3AST_AS.NewObject_type();
          ov_ot.lx_srcpos := type.lx_srcpos;
          TYPECASE type.as_exp_type OF
          | M3AST_AS.TYPE_SPEC(tts) =>
              ancestor := tts;
          | M3AST_AS.EXP(e) =>
              WITH aa = M3AST_AS.NewNamed_type() DO
                aa.lx_srcpos := ov_ot.lx_srcpos;
                aa.sm_type_spec := ts;
                ancestor := aa;
               WITH q = M3AST_AS.NewQual_used_id() DO
                aa.as_qual_id := q;
                q.as_id := M3AST_AS.NewUsed_def_id();
                TYPECASE e OF
                | M3AST_AS.Exp_used_id(u) =>
                    q.as_id.lx_srcpos := u.vUSED_ID.lx_srcpos;
                    q.as_id.lx_symrep := u.vUSED_ID.lx_symrep;
                    q.as_id.sm_def := u.vUSED_ID.sm_def;
                | M3AST_AS.Binary(b) =>
                    q.as_intf_id := M3AST_AS.NewUsed_interface_id();
                    WITH e1 = NARROW(b.as_exp1, M3AST_AS.Exp_used_id).vUSED_ID DO
                      q.as_intf_id.lx_srcpos := e1.lx_srcpos;
                      q.as_intf_id.lx_symrep := e1.lx_symrep;
                      q.as_intf_id.sm_def := e1.sm_def;
                    END;
                    WITH e2 = NARROW(b.as_exp2, M3AST_AS.Exp_used_id).vUSED_ID DO
                      q.as_id.lx_srcpos := e2.lx_srcpos;
                      q.as_id.lx_symrep := e2.lx_symrep;
                      q.as_id.sm_def := e2.sm_def;
                    END;
                END; (* typecase *)
               END; (* with *)
              END; (* with *)
          END; (* typecase *)
          ov_ot.as_ancestor := ancestor;
          new_actual := M3AST_AS.NewActual();
          SeqM3AST_AS_Actual.AddFront(new_param_s, new_actual);
          new_actual.as_exp_type := ov_ot;
        END; (* if *)
        WITH override = M3AST_AS.NewOverride() DO
          WITH override_id = M3AST_AS.NewOverride_id() DO
            override_id.lx_srcpos := actual.as_id.lx_srcpos;
            override_id.lx_symrep := NARROW(actual.as_id,
                M3AST_AS.Exp_used_id).vUSED_ID.lx_symrep;
            override.as_id := override_id;
          END;
          override.as_default := actual.as_exp_type;
          SeqM3AST_AS_Override.AddRear(ov_ot.as_override_s, override);
        END;
      ELSE
        new_actual := actual;
        SeqM3AST_AS_Actual.AddRear(new_param_s, new_actual);
      END; (* if *)
    END; (* while *)

    IF started THEN
      (* set temporary/semantic attributes on the new object type *)
      M3CTmpAtt.Set(ov_ot, unit_id);
      M3CEncTypeSpec.Set(ov_ot);
      M3CTypeSpecS.Set(ov_ot, unit_id.sm_spec);
      (* set the semantic attributes on the object overrides *)
      VAR iter := SeqM3AST_AS_Override.NewIter(ov_ot.as_override_s);
        override: M3AST_AS.Override;
      BEGIN
        WHILE SeqM3AST_AS_Override.Next(iter, override) DO
          M3CSpec.Set(override);
          M3CInitExp.Set(override);
          M3CTmpAtt.Set(override.as_id, unit_id);
        END; (* while *)
      END;
      call.sm_norm_actual_s := new_param_s;
    END;
  END CreateOverride;

PROCEDURE IsMethod(
    e: M3AST_AS.Exp_used_id;
    ts: M3AST_AS.Object_type)
    : BOOLEAN
    RAISES {}=
  VAR
    iter := M3ASTNext.NewIterFieldOrMethod(ts);
    f: M3AST_AS.Field_id;
    m: M3AST_AS.Method;
    symrep: M3AST_LX.Symbol_rep;
  BEGIN
    (* search back through the type hierarchy, until we
       find a matching symbol. Return TRUE iff it is a method. *)
    WHILE M3ASTNext.FieldOrMethod(iter, f, m, symrep) DO
      IF symrep = e.vUSED_ID.lx_symrep THEN
        RETURN m # NIL;
      END; (* if *)
    END; (* while *)
    RETURN FALSE; (* mismatch; error elsewhere *)
  END IsMethod;


BEGIN
END M3CNEWNorm.