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

MODULE M3CharStatsToConsider;

IMPORT AST, ASTWalk;
IMPORT M3AST_AS, M3AST_LX;
IMPORT M3AST_AS_F, M3AST_SM_F;
IMPORT M3AST_PG, M3AST_PG_F;
IMPORT SeqM3AST_AS_EXP, SeqM3AST_AS_Var_id, SeqM3AST_AS_Field_id;
IMPORT SeqM3AST_AS_Actual, SeqM3AST_AS_M3TYPE,
       SeqM3AST_AS_FORMAL_ID;
IMPORT M3Error, M3CStdProcs, M3ASTNext, M3Assert, M3CTypesMisc;
IMPORT M3CSrcPos;
IMPORT M3CharPreds;

TYPE
  RefStack = REF RECORD
                   len : INTEGER               := 0;
                   elts: REF ARRAY OF REFANY;
                   next: RefStack              := NIL END;

PROCEDURE RefStack_Push (rs: RefStack; elt: REFANY) RAISES {} =
  BEGIN
    IF rs.len = NUMBER(rs.elts^) THEN
      WITH na = NEW(REF ARRAY OF REFANY, rs.len * 2) DO
        FOR i := 0 TO rs.len - 1 DO na[i] := rs.elts[i] END;
        rs.elts := na; END END;
    rs.elts[rs.len] := elt;
    INC(rs.len);
  END RefStack_Push;

PROCEDURE RefStack_Pop (rs: RefStack; elt: REFANY) RAISES {} =
  BEGIN
    IF rs.elts[rs.len - 1] # elt THEN
      M3Error.ReportAtPos(M3CSrcPos.Null, "RefStack_Pop fails")
    ELSE
      DEC(rs.len) END
  END RefStack_Pop;

VAR
  stackPool           := NEW(MUTEX);
  stacks   : RefStack := NIL;

REVEAL
  Handle = Public BRANDED OBJECT
             results: RefStack
           OVERRIDES
             callback := Node; END;

PROCEDURE NewHandle (): Handle RAISES {} =
  VAR rs: RefStack;
  BEGIN
    LOCK stackPool DO
      IF stacks = NIL THEN
        rs := NEW(RefStack, elts := NEW(REF ARRAY OF REFANY, 100));
      ELSE
        rs := stacks;
        stacks := stacks.next END; END;
    TRY
      RETURN NEW(Handle, results := rs).init()
    FINALLY
      LOCK stackPool DO rs.next := stacks; stacks := rs; END END
  END NewHandle;

CONST noteDullDecls = FALSE;

PROCEDURE Node (h: Handle; n: AST.NODE; vm: ASTWalk.VisitMode)
  RAISES {} =
  VAR e: M3AST_PG.EXTERNAL_ID;
  BEGIN
    TYPECASE n OF
    | M3AST_AS.Proc_decl (pd) =>
        CASE vm OF
        | ASTWalk.VisitMode.Entry =>
            RefStack_Push(h.results, pd.as_type.as_result_type);
        | ASTWalk.VisitMode.Exit =>
            RefStack_Pop(h.results, pd.as_type.as_result_type); END;
    ELSE END;
    IF vm = ASTWalk.VisitMode.Entry THEN
      IF n # NIL AND M3AST_PG.IsA_EXTERNAL_ID(n, e) THEN
        IF e # NIL AND e.pg_external # NIL THEN
          TYPECASE n OF
          | M3AST_AS.TYPED_ID (tid) =>
              IF tid.sm_type_spec # NIL
                   AND M3CharPreds.Tm(tid.sm_type_spec) THEN
                M3Error.WarnWithId(
                  n, "Decl of EXTERNAL Tm item %s", tid.lx_symrep)
              ELSIF noteDullDecls THEN
                M3Error.WarnWithId(
                  n, "Decl of EXTERNAL non-Tm item %s",
                  tid.lx_symrep) END
          ELSE END END END;

      TYPECASE n OF
      | M3AST_AS.NEWCall (call) =>
          IF call.as_param_s = NIL THEN
            M3Error.Report(call, "NIL call.as_param_s");
          ELSE
            VAR
              a0      := SeqM3AST_AS_Actual.First(call.as_param_s);
              rfcType := EXP_TYPE_To_TS(call, a0.as_exp_type);
              rfcTS := M3CTypesMisc.CheckedUnpack(
                         M3CharPreds.M3TYPE_To_TYPE_SPEC(rfcType));
              nOpen := CountOpen(rfcTS);
              iter_a := SeqM3AST_AS_Actual.NewIter(call.as_param_s);
              a_len := SeqM3AST_AS_Actual.Length(call.as_param_s);
              actual: M3AST_AS.Actual;
            BEGIN
              IF nOpen + 1 > a_len THEN
                M3Error.Warn(
                  call, "Fewer actuals than levels of open array");
                RETURN END;
              IF nOpen + 1 = a_len THEN RETURN END;
              FOR i := 0 TO nOpen DO
                IF NOT SeqM3AST_AS_Actual.Next(iter_a, actual) THEN
                  M3Error.Report(
                    call, "Alleged open actual fails to enumerate"); END; END;
              FOR i := nOpen + 1 TO a_len - 1 DO
                IF NOT SeqM3AST_AS_Actual.Next(iter_a, actual) THEN
                  M3Error.Report(
                    call,
                    "SeqM3AST_AS_Actual.Next exhausted before alleged length");
                  RETURN END;
                TYPECASE actual.as_exp_type OF
                | M3AST_AS.M3TYPE =>
                    M3Error.Report(actual, "Actual is a TYPE");
                | M3AST_AS.EXP (ae) =>
                    TYPECASE actual.as_id OF
                    | NULL =>
                        M3Error.Warn(actual, "Actual.as_id=NIL");
                    | M3AST_AS.Exp_used_id (e) =>
                        TYPECASE e.vUSED_ID.sm_def OF
                        | NULL =>
                            M3Error.Warn(
                              actual,
                              "actual.as_id.vUSED_ID.sm_def=NIL");
                        | M3AST_AS.Field_id (fid) =>
                            IF ae.sm_exp_type_spec # NIL THEN
                              CheckAssign(
                                actual, ae.sm_exp_type_spec,
                                fid.sm_type_spec); END
                        ELSE
                          M3Error.Warn(
                            actual,
                            "Weird actual.as_id.vUSED_ID.sm_def"); END
                    ELSE
                      M3Error.Warn(actual, "Weird actual.as_id"); END;
                ELSE END (*typecase*); END (*do*);
            END END;
      | M3AST_AS.Call (call) =>
          VAR st_call: M3CStdProcs.T;
          BEGIN
            IF M3CStdProcs.IsStandardCall(call, st_call) THEN
              CASE st_call OF
              | M3CStdProcs.T.Inc, M3CStdProcs.T.Dec =>
                  WITH ta = SeqM3AST_AS_EXP.First(call.sm_actual_s) DO
                    IF M3CharPreds.Tn(ta.sm_exp_type_spec) THEN
                      M3Error.Warn(
                        call,
                        "INC/DEC of a NUM(CHAR)-dependent type"); END; END;
              ELSE END;
            ELSE
              (* not a builtin call *)
              VAR
                iter_a := SeqM3AST_AS_EXP.NewIter(call.sm_actual_s);
                exp: M3AST_AS.EXP;
                proc_type := NARROW(
                               call.as_callexp.sm_exp_type_spec,
                               M3AST_AS.Procedure_type);
                iter_f       : M3ASTNext.IterFormal;
                hidden_formal: BOOLEAN;
                formal_param : M3AST_AS.Formal_param;
                formal_id    : M3AST_AS.FORMAL_ID;
                formal_type  : M3AST_AS.TYPE_SPEC;
                hidden_tid   : M3AST_AS.Type_id;
                formal_sym   : M3AST_LX.Symbol_rep;
                check_copy   : BOOLEAN;
              BEGIN
                IF proc_type = NIL THEN RETURN END;
                hidden_formal :=
                  proc_type.sm_def_id # NIL
                    AND ISTYPE(
                          proc_type.sm_def_id, M3AST_AS.Type_id);
                iter_f :=
                  M3ASTNext.NewIterFormal(
                    proc_type.as_formal_param_s);

                WHILE SeqM3AST_AS_EXP.Next(iter_a, exp) DO
                  IF hidden_formal THEN (* T.m *)
                    hidden_formal := FALSE;
                    hidden_tid :=
                      NARROW(proc_type.sm_def_id, M3AST_AS.Type_id);
                    formal_type := hidden_tid.sm_type_spec;
                    formal_sym := hidden_tid.lx_symrep;
                    check_copy := TRUE;
                  ELSE
                    M3Assert.Check(
                      M3ASTNext.Formal(
                        iter_f, formal_param, formal_id));
                    formal_sym := formal_id.lx_symrep;
                    formal_type := formal_id.sm_type_spec;
                    TYPECASE formal_id OF
                    | M3AST_AS.F_Value_id => check_copy := TRUE;
                    | M3AST_AS.F_Var_id, M3AST_AS.F_Readonly_id =>
                        check_copy := FALSE; END; END; (* if *)
                  CheckAssign(
                    call, exp.sm_exp_type_spec, formal_type,
                    formal_sym, check_copy := check_copy); END; (* while *)
              END; END;
          END;

      | M3AST_AS.Raise_st (r) =>
          IF r.as_exp_void # NIL THEN
            TYPECASE r.as_qual_id.as_id.sm_def OF
            | NULL =>
                M3Error.Report(r, "r.as_qual_id.as_id.sm_def=NIL");
            | M3AST_AS.TYPED_ID (tid) =>
                CheckAssign(
                  r, r.as_exp_void.sm_exp_type_spec,
                  tid.sm_type_spec, check_copy := FALSE);
            ELSE
              M3Error.Report(r, "Weird r.as_qual_id.as_id.sm_def"); END END;

      | M3AST_AS.Handler_id (hid) =>
          IF hid.sm_type_spec # NIL THEN
            CheckAssign(hid, hid.sm_type_spec, hid.sm_type_spec);
          ELSE
            M3Error.Report(hid, "Unset Handler_id.sm_type_spec"); END;

      | M3AST_AS.Return_st (r) =>
          IF h.results.len = 0 THEN
            M3Error.Report(n, "RETURN outside PROC decl")
          ELSIF r.as_exp = NIL THEN
            EVAL 0
          ELSE
            TYPECASE h.results.elts[h.results.len - 1] OF
            | M3AST_AS.M3TYPE (t) =>
                CheckAssign(
                  r, r.as_exp.sm_exp_type_spec,
                  M3CharPreds.M3TYPE_To_TYPE_SPEC(t), check_copy := FALSE);
            ELSE
              M3Error.Report(r, "RETURN to non-M3TYPE") END END;

      | M3AST_AS.Var_decl (vd) =>
          IF vd.as_default # NIL THEN
            CheckAssign(
              vd, vd.as_default.sm_exp_type_spec,
              SeqM3AST_AS_Var_id.First(vd.as_id_s).sm_type_spec); END;

      | M3AST_AS.Formal_param (fp) =>
          VAR
            ff  := SeqM3AST_AS_FORMAL_ID.First(fp.as_id_s);
            fts := ff.sm_type_spec;
          BEGIN
            IF fp.as_default # NIL THEN
              CheckAssign(
                fp, fp.as_default.sm_exp_type_spec, fts,
                check_copy := FALSE); END;
            TYPECASE ff OF
            | M3AST_AS.F_Value_id =>
                CheckAssign(fp, fts, fts, check_assy := FALSE);
            | M3AST_AS.F_Var_id, M3AST_AS.F_Readonly_id => EVAL 0; END;

          END;

      | M3AST_AS.Fields (fs) =>
          WITH fid = SeqM3AST_AS_Field_id.First(fs.as_id_s) DO
            TYPECASE fid.vRECOBJ_ID.sm_enc_type_spec OF
            | NULL =>
                M3Error.Report(
                  fs, "fid.vRECOBJ_ID.sm_enc_type_spec=NIL");
            | M3AST_AS.Record_type => EVAL 0;
            | M3AST_AS.Object_type =>
                IF M3CharPreds.TC(fid.sm_type_spec, M3CharPreds.Tr) THEN
                  M3Error.Warn(
                    fs, "Object field containing changing type") END;
            ELSE
              M3Error.Report(
                fs, "Weird fid.vRECOBJ_ID.sm_enc_type_spec") END;
            IF fs.as_default # NIL THEN
              CheckAssign(
                fs, fs.as_default.sm_exp_type_spec,
                fid.sm_type_spec); END; END;

      | M3AST_AS.Assign_st (as_st) =>
          CheckAssign(
            as_st, as_st.as_rhs_exp.sm_exp_type_spec,
            as_st.as_lhs_exp.sm_exp_type_spec);
      ELSE END;                  (* typecase *)
      END;                       (* if *)
  END Node;

PROCEDURE CheckAssign (n             : AST.NODE;
                       ts_from, ts_to: M3AST_AS.TYPE_SPEC;
                       formal: M3AST_LX.Symbol_rep := NIL;
                       check_assy, check_copy := TRUE) =
  BEGIN
    IF ts_from = NIL OR ts_to = NIL THEN
      M3Error.Report(n, "ts_from or ts_to is NIL")
    ELSE
      IF check_assy AND ts_from # ts_to
           AND (M3CharPreds.TC(ts_from, M3CharPreds.ArrayTnOf)
                  OR M3CharPreds.TC(ts_to, M3CharPreds.ArrayTnOf)) THEN
        IF formal # NIL THEN
          M3Error.WarnWithId(
            n,
            "assignment to/from NUM(CHAR)-dependent array at formal %s",
            formal);
        ELSE
          M3Error.Warn(
            n, "assignment to/from NUM(CHAR)-dependent array"); END; END; END;
    IF check_copy AND ts_to # NIL AND M3CharPreds.TC(ts_to, M3CharPreds.Th) THEN
      IF formal # NIL THEN
        M3Error.WarnWithId(
          n, "Copy of becoming-huge value at formal %s", formal);
      ELSE
        M3Error.Warn(n, "Copy of becoming-huge value"); END; END;
  END CheckAssign;

PROCEDURE CountOpen (ts: M3AST_AS.TYPE_SPEC): INTEGER =
  VAR rts := M3CTypesMisc.Reveal(ts);
  PROCEDURE PerArray (t: M3AST_AS.M3TYPE): INTEGER =
    VAR ts := M3CharPreds.M3TYPE_To_TYPE_SPEC(t);
    BEGIN
      TYPECASE ts OF
      | NULL => RETURN 0;
      | M3AST_AS.Array_type (at) =>
          WITH nat = at.sm_norm_type DO
            IF SeqM3AST_AS_M3TYPE.Empty(nat.as_indextype_s)
                 OR SeqM3AST_AS_M3TYPE.First(nat.as_indextype_s)
                      = NIL THEN
              RETURN 1 + PerArray(nat.as_elementtype) END; END
      ELSE END;
      RETURN 0;
    END PerArray;
  BEGIN
    TYPECASE rts OF
    | NULL => RETURN 0;
    | M3AST_AS.Ref_type (rt) => RETURN PerArray(rt.as_type);
    ELSE
      RETURN 0 END;
  END CountOpen;

PROCEDURE EXP_TYPE_To_TS (call: M3AST_AS.NEWCall;
                          et  : M3AST_AS.EXP_TYPE ):
  M3AST_AS.TYPE_SPEC =
  PROCEDURE UI (ui: M3AST_AS.USED_ID): M3AST_AS.TYPE_SPEC =
    BEGIN
      TYPECASE ui.sm_def OF
      | NULL => M3Error.Report(call, "ui.sm_def=NIL");
      | M3AST_AS.Type_id (tid) =>
          IF tid.sm_type_spec # NIL THEN
            RETURN tid.sm_type_spec
          ELSE
            M3Error.Report(call, "ui.sm_def._type_spec=NIL"); END;
      ELSE
        M3Error.Report(call, "Weird ui.sm_def") END;
      RETURN NIL;
    END UI;
  BEGIN
    TYPECASE et OF
    | M3AST_AS.M3TYPE (t) => RETURN M3CharPreds.M3TYPE_To_TYPE_SPEC(t);
    | M3AST_AS.Exp_used_id (eui) => RETURN UI(eui.vUSED_ID);
    | M3AST_AS.Binary (b) =>
        TYPECASE b.as_binary_op OF
        | NULL =>
            M3Error.Report(call, "1st arg to NEW() is .. NIL ..");
            RETURN NIL;
        | M3AST_AS.Select => EVAL 0;
        ELSE
          M3Error.Report(call, "1st arg to NEW() is .. weird ..");
          RETURN NIL; END;
        TYPECASE b.as_exp2 OF
        | NULL =>
            M3Error.Report(
              call, "1st arg to NEW() is Select(.., NIL)");
        | M3AST_AS.Exp_used_id (eui) => RETURN UI(eui.vUSED_ID);
        | M3AST_AS.Bad_EXP =>
            M3Error.Report(
              call, "1st arg to NEW() is Select(.., Bad_EXP)");
        ELSE
          M3Error.Report(
            call, "1st arg to NEW() is Select(.., weird)") END;
        RETURN NIL;
    | M3AST_AS.Bad_EXP =>
        M3Error.Report(call, "1st arg to NEW() is Bad_EXP");
    | M3AST_AS.EXP =>
        M3Error.Report(call, "1st arg to NEW() is an expr");
    ELSE
      M3Error.Report(call, "Weird 1st arg to NEW()"); END;
    RETURN NIL;
  END EXP_TYPE_To_TS;

BEGIN

END M3CharStatsToConsider.