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

(* File: IsType.m3                                             *)
(* Last Modified On Thu Feb 27 16:48:41 PST 1992 By kalsow     *)
(*      Modified On Sat Dec  8 00:54:22 1990 By muller         *)

MODULE IsType;

IMPORT CallExpr, Expr, Type, Error, TypeExpr, Reff, RefType;
IMPORT Temp, Procedure, Bool, Emit, ObjectType, Null, Frame;

VAR Z: CallExpr.MethodList;

PROCEDURE Check (<*UNUSED*> proc: Expr.T; VAR args: Expr.List;  <*UNUSED*> VAR cs: Expr.CheckState): Type.T =
  VAR t, u: Type.T;
  BEGIN
    IF  NOT TypeExpr.Split (args[1], t) THEN
      Error.Msg ("ISTYPE: second argument must be a type");
      t := Expr.TypeOf (args[0]);
    END;
    t := Type.Base (t);
    u := Expr.TypeOf (args[0]);
    IF ObjectType.Is (t) THEN
      (* ok *)
    ELSIF (NOT Type.IsSubtype (t, Reff.T)) THEN
      Error.Msg ("ISTYPE: must be a traced reference type");
    ELSIF (NOT Type.IsAssignable (t, u)) THEN
      Error.Msg ("ISTYPE: types must be assignable");
    ELSE (* REF type *)
      (* ok *)
    END;
    RETURN Bool.T;
  END Check;

PROCEDURE Compile (<*UNUSED*> proc: Expr.T; args: Expr.List): Temp.T =
  VAR t1, t2: Temp.T;  t, u: Type.T;  block: INTEGER;
  BEGIN
    IF  NOT TypeExpr.Split (args[1], t) THEN
      t := Expr.TypeOf (args[0]);
    END;
    Type.Compile (t);
    t := Type.Base (t);
    u := Expr.TypeOf (args[0]);

    t1 := Expr.Compile (args[0]);
    t2 := Temp.AllocEmpty (Bool.T);
    IF Type.IsSubtype (u, t) THEN
      (* the test succeeds statically *)
      Emit.OpT ("@ = 1;\n", t2);
    ELSIF Type.IsEqual (t, Null.T, NIL) THEN
      Emit.OpTT ("@ = (@ == _NIL);\n", t2, t1);
    ELSIF RefType.Is (t) THEN
      Frame.PushBlock (block, 1);
      Emit.OpTT ("register _ADDRESS _ref = (_ADDRESS) @;\n@ = ", t1,t2);
      Emit.OpF  ("_ISTYPE (_ref, @_TC);\n", t);
      Frame.PopBlock (block);
    ELSE
      Frame.PushBlock (block, 2);
      Emit.OpT ("register _ADDRESS _ref = (_ADDRESS) @;\n", t1);
      Emit.Op  ("register int _tc = _TYPECODE (_ref);\n");
      Emit.OpT ("@ = _ISSUBTYPE (_tc, ", t2);
      Emit.OpF ("@_TC);\n", t);
      Frame.PopBlock (block);
    END;
    Temp.Free (t1);
    RETURN t2;
  END Compile;

PROCEDURE Fold (<*UNUSED*> proc: Expr.T; <*UNUSED*> args: Expr.List): Expr.T =
  BEGIN
    RETURN NIL;
  END Fold;

PROCEDURE Initialize () =
  BEGIN
    Z := CallExpr.NewMethodList (2, 2, TRUE, FALSE, Bool.T,
                                 NIL, Check, Compile, Fold,
                                 CallExpr.IsNever, (* writable *)
                                 CallExpr.IsNever (* designator *));
    Procedure.Define ("ISTYPE", Z, TRUE);
  END Initialize;

BEGIN
END IsType.