m3tk/src/sem/M3CStdActualS.m3


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;
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. *)
          VAR ta: M3AST_SM.TypeActual := NEW(M3AST_SM.TypeActual).init();
          BEGIN
            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 <*NOWARN*>
        | 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.