MODULE M3CStdActualS;

(***************************************************************************)
(*                      Copyright (C) Olivetti 1989                        *)
(*                          All Rights reserved                            *)
(*                                                                         *)
(* Use and copy of this software and preparation of derivative works based *)
(* upon this software are permitted to any person, provided this same      *)
(* copyright notice and the following Olivetti warranty disclaimer are     *) 
(* included in any copy of the software or any modification thereof or     *)
(* derivative work therefrom made by any person.                           *)
(*                                                                         *)
(* This software is made available AS IS and Olivetti disclaims all        *)
(* warranties with respect to this software, whether expressed or implied  *)
(* under any law, including all implied warranties of merchantibility and  *)
(* fitness for any purpose. In no event shall Olivetti be liable for any   *)
(* damages whatsoever resulting from loss of use, data or profits or       *)
(* otherwise arising out of or in connection with the use or performance   *)
(* of this software.                                                       *)
(***************************************************************************)

IMPORT Text;

IMPORT M3AST_AS, M3AST_SM, M3ASTNext;

IMPORT M3AST_AS_F, M3AST_SM_F;

IMPORT SeqM3AST_AS_EXP;

IMPORT M3CStdProcs, M3CTypesMisc, M3CTypeChkUtil, M3CActualUtil, M3CExpsMisc,
    M3CTypeRelation, M3Error, M3CStdTypes,
    M3COrdinal, M3CBackEnd;


(* First 'Set' and the routines it uses to build the sm_actual_s list, check
the number and class of actuals etc. *)

PROCEDURE IsCorrectClass(
    pf: M3CStdProcs.T;
    pos: INTEGER;
    class: M3CExpsMisc.Class)
    : BOOLEAN
    RAISES {}=
  BEGIN
    CASE class OF
    | M3CExpsMisc.Class.Type =>
        IF pos = 0 THEN
          RETURN pf IN M3CStdProcs.FirstParameterCanBeType;
        ELSE
          RETURN pos = 1 AND pf IN M3CStdProcs.SecondParameterCanBeType;
        END; (* if *)
    | M3CExpsMisc.Class.Normal =>
        IF pos = 0 THEN
          RETURN pf IN M3CStdProcs.FirstParameterCanBeNormal;
        ELSE
          RETURN pos > 1 OR pf IN M3CStdProcs.SecondParameterCanBeNormal;
        END; (* if *)
    ELSE
      RETURN FALSE;
    END; (* case *)
  END IsCorrectClass;


<*INLINE*> PROCEDURE CheckClass(
    call: M3AST_AS.Call;
    pf: M3CStdProcs.T;
    pos: INTEGER;
    exp: M3AST_SM.EXP_UNSET)
    : M3AST_SM.EXP_UNSET
    RAISES {}=
  VAR
    class: M3CExpsMisc.Class;
  BEGIN
    IF exp = NIL THEN RETURN NIL END;
    IF ISTYPE(exp, M3AST_SM.TypeActual) THEN
      class := M3CExpsMisc.Class.Type;
    ELSE
      class := M3CExpsMisc.Class.Normal;
    END;
    IF IsCorrectClass(pf, pos, class) THEN
      RETURN exp;
    ELSE
      (* We need original actual because 'exp' may be type actual, which is
       not an original part of the tree and will not be walked by the error
       detection pass *)
      M3CExpsMisc.WrongClass(M3CActualUtil.OriginalActual(call, pos), class);
      RETURN NIL;
    END;
  END CheckClass;


PROCEDURE Set(call: M3AST_AS.Call; pf: M3CStdProcs.T) RAISES {}=
  VAR
    actuals := M3CActualUtil.ActualList(call, TRUE);
    count := M3CActualUtil.PositionalActuals(actuals);
    iter: M3ASTNext.IterFormal;
    pos := 0;
    formal: M3AST_AS.Formal_param;
    formalId: M3AST_AS.FORMAL_ID;
    exp: M3AST_SM.EXP_UNSET;
  BEGIN
    WITH procType =
        NARROW(call.as_callexp.sm_exp_type_spec, M3AST_AS.Procedure_type) DO
      iter := M3ASTNext.NewIterFormal(procType.as_formal_param_s);
    END;
    pos := 0;
    LOOP
      IF NOT M3ASTNext.Formal(iter, formal, formalId) THEN EXIT END;
      IF pos >= count THEN
        IF pf = M3CStdProcs.T.Float THEN
          (* cant represent a default formal of Type_type, so fix up here. *)
          WITH ta = M3AST_SM.NewTypeActual() DO
            ta.sm_exp_type_spec := M3CStdTypes.Real();
            SeqM3AST_AS_EXP.AddRear(call.sm_actual_s, ta);
          END;
        ELSIF NOT M3CActualUtil.AddDefault(call, formal) THEN
          M3CActualUtil.TooFewArguments(call);
          EXIT;
        END; (* if *)
      ELSE
        exp := CheckClass(call, pf, pos,
            M3CActualUtil.ActualAt(actuals, pos, NIL));
        SeqM3AST_AS_EXP.AddRear(call.sm_actual_s, exp);
      END; (* if *)
      INC(pos);
    END; (* loop *)
    IF pos < count THEN M3CActualUtil.TooManyArguments(call) END;
    M3CActualUtil.FindUnmatched(actuals);
  END Set;


(* type errors *)

CONST
  WrongType = "argument is wrong type";
  NotWriteableDesignator = "argument is not writeable designator";
  BadTypeConversion = "cannot convert to given type";
  IllegalOpenArray = "argument is open array";
  NotDesignator = "argument is not designator";
  BoundOfEmptyEnumeration = "cannot find bound of empty enumeration type";


PROCEDURE Error(
    call: M3AST_AS.Call;
    pos: INTEGER;
    exp: M3AST_AS.EXP;
    msg: Text.T)
    RAISES {}=
  VAR
    actual: M3AST_AS.Actual;
    en: M3Error.ERROR_NODE;
  BEGIN
    IF ISTYPE(exp, M3AST_SM.TypeActual) THEN
      (* can't hang error from it; it's not part of the syntactic tree *)
      actual := M3CActualUtil.OriginalActual(call, pos);
      en := actual.as_exp_type;
    ELSE
      en := exp;
    END; (* if *)
    M3Error.Report(en, msg);
  END Error;


PROCEDURE UnsafeCall(call: M3AST_AS.Call) RAISES {}=
  VAR
  BEGIN
    M3Error.Report(call, "unsafe call not permitted in safe module");
  END UnsafeCall;


(* utility routines for simple type and expression checking *)

PROCEDURE LoopholePossible(
    type: M3AST_SM.TYPE_SPEC_UNSET;
    exp: M3AST_SM.EXP_UNSET)
    : BOOLEAN
    RAISES {}=
  BEGIN
    IF exp = NIL OR exp.sm_exp_type_spec = NIL OR type = NIL THEN
      RETURN TRUE; (* something else is already wrong *)
    ELSE
      WITH ets = exp.sm_exp_type_spec DO
        IF M3CTypesMisc.IsOpenArray(type) THEN
          (* element type cannot be open array and size must divide exactly *)
          VAR at := NARROW(type, M3AST_AS.Array_type);
              ats: M3AST_AS.TYPE_SPEC;
          BEGIN
            M3CTypesMisc.GetTYPE_SPECFromM3TYPE(at.as_elementtype, ats);
            IF M3CTypesMisc.IsOpenArray(ats) THEN RETURN FALSE
            ELSE
              IF ets.sm_bitsize <= 0 OR  ats.sm_bitsize <= 0 THEN
                RETURN TRUE (* something else is already wrong *)
              ELSE
                RETURN ets.sm_bitsize MOD ats.sm_bitsize = 0;
              END
            END
          END;
        ELSE
          RETURN type.sm_bitsize = ets.sm_bitsize;
        END;
      END;
    END
  END LoopholePossible;


PROCEDURE IsTracedOrIsObject(
    type: M3AST_SM.TYPE_SPEC_UNSET)
    : BOOLEAN
    RAISES {}=
  VAR
    reveal: M3AST_SM.TYPE_SPEC_UNSET;
  BEGIN
    IF M3CTypesMisc.IsTracedRef(type) IN M3CTypesMisc.ProbablyTraced THEN
      (* this arm catches 'NIL' *)
      RETURN TRUE;
    ELSE
      reveal := M3CTypesMisc.Reveal(type);
      RETURN reveal = NIL OR ISTYPE(reveal, M3AST_AS.Object_type) OR
          ISTYPE(reveal, M3AST_AS.Root_type);
    END;
  END IsTracedOrIsObject;


TYPE
  Array = {Not, Open, Errant, Ordinal};


PROCEDURE IsArray(
    type: M3AST_SM.TYPE_SPEC_UNSET;
    VAR index: M3AST_SM.TYPE_SPEC_UNSET)
    : Array
    RAISES {}=
  BEGIN
    TYPECASE type OF
    | NULL =>
        RETURN Array.Errant;
    | M3AST_AS.Array_type(at) =>
        CASE M3CTypesMisc.Index(at, index) OF
        | M3CTypesMisc.Ix.Unknown, M3CTypesMisc.Ix.Bad =>
            RETURN Array.Errant;
        | M3CTypesMisc.Ix.Open =>
            RETURN Array.Open;
        | M3CTypesMisc.Ix.Ordinal =>
            RETURN Array.Ordinal;
        END;
    ELSE
      RETURN Array.Not;
    END; (* if *)
  END IsArray;


PROCEDURE SameBaseType(
    type1, type2: M3AST_SM.TYPE_SPEC_UNSET)
    : BOOLEAN
    RAISES {}=
  BEGIN
    RETURN M3CTypeRelation.SameOrdinalSupertype(type1, type2) OR
        M3CTypeRelation.Identical(type1, type2);
  END SameBaseType;


PROCEDURE IsReal(type: M3AST_SM.TYPE_SPEC_UNSET): BOOLEAN RAISES {}=
  BEGIN
    RETURN type = NIL OR ISTYPE(type, M3AST_AS.FLOAT_TYPE);
  END IsReal;


PROCEDURE Disposable(type: M3AST_SM.TYPE_SPEC_UNSET): BOOLEAN RAISES {}=
  BEGIN
    TYPECASE type OF
    | M3AST_AS.Ref_type, M3AST_AS.Object_type =>
        (* Catches NULL *)
        RETURN TRUE;
    | M3AST_AS.Opaque_type =>
        RETURN M3CTypesMisc.IsConcrete(type, FALSE);
    ELSE
      RETURN FALSE;
    END;
  END Disposable;


PROCEDURE IsDesignator(
    exp: M3AST_SM.EXP_UNSET;
    VAR writeable: BOOLEAN)
    : BOOLEAN
    RAISES {}=
  BEGIN
    IF exp # NIL THEN
      RETURN M3CExpsMisc.IsDesignator(exp, writeable);
    ELSE
      writeable := TRUE;
      RETURN TRUE;
    END; (* if *)
  END IsDesignator;


PROCEDURE IsWriteableDesignator(exp: M3AST_SM.EXP_UNSET): BOOLEAN RAISES {}=
  VAR
    writeable: BOOLEAN;
  BEGIN
    RETURN IsDesignator(exp, writeable) AND writeable;
  END IsWriteableDesignator;


PROCEDURE ExprAssignable(
    type: M3AST_SM.TYPE_SPEC_UNSET;
    exp: M3AST_SM.EXP_UNSET;
    safe: BOOLEAN)
    : BOOLEAN
    RAISES {}=
  BEGIN
    IF exp # NIL THEN
      RETURN M3CTypeChkUtil.EXPAssignable(type, exp, safe);
    ELSE
      RETURN TRUE;
    END; (* if *)
  END ExprAssignable;


PROCEDURE ExprAssignableToCardinal(
    exp: M3AST_SM.EXP_UNSET;
    safe: BOOLEAN)
    : BOOLEAN
    RAISES {}=
  BEGIN
    RETURN ExprAssignable(M3CStdTypes.Cardinal(), exp, safe);
  END ExprAssignableToCardinal;


PROCEDURE CheckOrdinalOrFloat(
    type: M3AST_SM.TYPE_SPEC_UNSET;
    number: BOOLEAN; floatOk: BOOLEAN)
    : Text.T
    RAISES {}=
  VAR
    baseType: M3AST_SM.TYPE_SPEC_UNSET;
  BEGIN
    IF floatOk AND NOT number AND
        ISTYPE(type, M3AST_AS.FLOAT_TYPE) THEN RETURN NIL END;

    IF NOT M3COrdinal.Is(type, baseType) THEN RETURN WrongType END;
    IF NOT number AND baseType # NIL AND
        ISTYPE(baseType, M3AST_AS.Enumeration_type) AND
        M3CTypesMisc.IsEmpty(baseType) THEN
      RETURN BoundOfEmptyEnumeration;
    ELSE
      RETURN NIL;
    END; (* if *)
  END CheckOrdinalOrFloat;


(* the main type checking routine *)

PROCEDURE TypeCheck(
    call: M3AST_AS.Call;
    pf: M3CStdProcs.T;
    safe: BOOLEAN)
    RAISES {}=
  VAR
    actuals := call.sm_actual_s;
    iter := SeqM3AST_AS_EXP.NewIter(actuals);
    pos := 0;
    wrongClass, isType, writeable: BOOLEAN;
    arg, prevArg: M3AST_SM.EXP_UNSET;
    type, prevType, baseType, index: M3AST_SM.TYPE_SPEC_UNSET;
    error: Text.T;
  BEGIN
    IF pf IN M3CStdProcs.Unsafe AND safe THEN
      UnsafeCall(call)
    END; (* if *)
    WHILE SeqM3AST_AS_EXP.Next(iter, arg) DO
      wrongClass := arg = NIL;
      isType := NOT wrongClass AND ISTYPE(arg, M3AST_SM.TypeActual);
      IF NOT wrongClass THEN
        type := arg.sm_exp_type_spec;
        error := NIL;
        CASE pf OF
        | M3CStdProcs.T.Inc, M3CStdProcs.T.Dec =>
            IF pos = 0 THEN
              IF NOT M3COrdinal.Is(type, baseType) AND
                  (safe OR NOT M3CTypeChkUtil.IsSubTypeOfAddress(type)) THEN
                error := WrongType;
              ELSIF NOT IsWriteableDesignator(arg) THEN
                error := NotWriteableDesignator
              END; (* if *)
            ELSE
              IF NOT M3CTypeChkUtil.IsSubTypeOfInteger(type) THEN
                error := WrongType;
              END;
            END; (* if *)
        | M3CStdProcs.T.Dispose =>
            IF NOT Disposable(type) THEN
              error := WrongType;
            ELSIF NOT IsWriteableDesignator(arg) THEN
              error := NotWriteableDesignator;
            END; (* if *)
        | M3CStdProcs.T.Abs =>
            IF NOT
                (M3CTypeChkUtil.IsSubTypeOfInteger(type) OR IsReal(type)) THEN
              error := WrongType;
            END; (* if *)
        | M3CStdProcs.T.Float =>
            IF pos = 0 THEN
              IF NOT
                 (M3CTypeChkUtil.IsSubTypeOfInteger(type) OR IsReal(type)) THEN
                error := WrongType;
              END; (* if *)
            ELSIF pos = 1 THEN
              IF NOT IsReal(type) THEN
                error := WrongType;
              END; (* if *)
            END; (* if *)
        | M3CStdProcs.T.Floor, M3CStdProcs.T.Ceiling,
          M3CStdProcs.T.Round, M3CStdProcs.T.Trunc =>
            IF NOT IsReal(type) THEN error := WrongType END;
        | M3CStdProcs.T.Max, M3CStdProcs.T.Min =>
            IF (NOT (M3COrdinal.Is(type, baseType) OR IsReal(type))) OR
                ((pos = 1) AND (NOT SameBaseType(prevType, type))) THEN
              error := WrongType;
            END; (* if *)
        | M3CStdProcs.T.Ord =>
            IF NOT M3COrdinal.Is(type, baseType) THEN error := WrongType END;
        | M3CStdProcs.T.Val =>
            IF pos = 0 THEN
              IF NOT M3CTypeChkUtil.IsSubTypeOfInteger(type) THEN
                error := WrongType;
              END;
            ELSE
              IF NOT M3COrdinal.Is(type, baseType) THEN error := WrongType END;
            END; (* if *)
        | M3CStdProcs.T.Number, M3CStdProcs.T.First, M3CStdProcs.T.Last =>
            CASE IsArray(type, index) OF
            | Array.Not =>
                IF isType THEN
                  error := CheckOrdinalOrFloat(type,
                      pf = M3CStdProcs.T.Number, TRUE);
                ELSE
                  error := WrongType;
                END;
            | Array.Ordinal =>
                error := CheckOrdinalOrFloat(index,
                    pf = M3CStdProcs.T.Number, FALSE);
            | Array.Open =>
                IF isType THEN error := WrongType END;
            | Array.Errant =>
            END;
        | M3CStdProcs.T.TypeCode =>
            IF isType THEN
              IF type # NIL AND
                  (NOT IsTracedOrIsObject(type) OR
                  ISTYPE(type, M3AST_AS.RefAny_type)) THEN
                error := WrongType;
              END;
            ELSE
              IF NOT IsTracedOrIsObject(type) THEN
                error := WrongType;
              END;
            END; (* if *)
        | M3CStdProcs.T.Narrow, M3CStdProcs.T.IsType =>
            IF pos = 0 THEN
              IF NOT IsTracedOrIsObject(type) THEN error := WrongType END;
            ELSE
              IF NOT IsTracedOrIsObject(type) THEN
                error := WrongType;
              ELSIF NOT ExprAssignable(type, prevArg, safe) THEN
                error := BadTypeConversion;
              END; (* if *)
            END; (* if *)
        | M3CStdProcs.T.BitSize, M3CStdProcs.T.ByteSize,
          M3CStdProcs.T.AdrSize =>
            IF isType THEN
              IF M3CTypesMisc.IsOpenArray(type) THEN
                error := IllegalOpenArray;
              END; (* if *)
            ELSE
              IF NOT IsDesignator(arg, writeable) THEN
                error := NotDesignator;
              END; (* if *)
            END; (* if *)
        | M3CStdProcs.T.Loophole =>
            IF pos = 0 THEN
              IF M3CTypesMisc.IsOpenArray(type) THEN
                error := IllegalOpenArray;
              END; (* if *)
            ELSE
              IF NOT LoopholePossible(type, prevArg) THEN
                error := BadTypeConversion;
              END; (* if *)
            END; (* if *)
        | M3CStdProcs.T.Adr =>
            IF NOT IsDesignator(arg, writeable) THEN
              error := NotDesignator;
            END; (* if *)
        | M3CStdProcs.T.Subarray =>
            IF pos = 0 THEN
              IF IsArray(type, index) = Array.Not THEN error := WrongType END;
            ELSE
              IF NOT ExprAssignableToCardinal(arg, safe) THEN
                 error := WrongType;
              END;
            END; (* if *)
        END; (* case *)
        IF error # NIL THEN Error(call, pos, arg, error) END;
      ELSE
        (* actual expression was wrong class - message already given by Set *)
      END; (* if *)
      INC(pos);
      IF (NOT wrongClass) AND (error = NIL) THEN
        prevArg := arg; prevType := type;
      ELSE
        prevArg := NIL;
        prevType := NIL;
      END; (* if *) 
    END; (* while *)
  END TypeCheck;


BEGIN
END M3CStdActualS.