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

(* File: Typecode.m3                                           *)
(* Last Modified On Fri Mar  6 15:03:52 PST 1992 By kalsow     *)
(*      Modified On Fri Mar 15 03:50:01 1991 By muller         *)

MODULE Typecode;

IMPORT CallExpr, Expr, Type, Procedure, Card, Error;
IMPORT Reff, TypeExpr, Emit, Temp, ObjectType;

VAR Z: CallExpr.MethodList;

PROCEDURE Check (<*UNUSED*> proc: Expr.T; VAR args: Expr.List;  <*UNUSED*> VAR cs: Expr.CheckState): Type.T =
  VAR t: Type.T;
  BEGIN
    IF TypeExpr.Split (args[0], t) THEN
      IF (ObjectType.Is (t)) THEN
        (* ok *)
      ELSIF (Type.IsEqual (t, Reff.T, NIL)) THEN
        Error.Msg ("TYPECODE: T must be a fixed reference type");
      ELSIF (NOT Type.IsSubtype (t, Reff.T)) THEN
        Error.Msg ("TYPECODE: T must be a traced reference type");
      END;
    ELSE
      t := Expr.TypeOf (args[0]);
      IF NOT Type.IsSubtype (t, Reff.T) AND NOT ObjectType.Is (t) THEN
        Error.Msg ("TYPECODE: r must be a traced reference or object");
      END;
    END;
    RETURN Card.T;
  END Check;

PROCEDURE Compile (<*UNUSED*> proc: Expr.T; args: Expr.List): Temp.T =
  VAR t1, t2: Temp.T;  t: Type.T;
  BEGIN
    IF TypeExpr.Split (args[0], t) THEN
      Type.Compile (t);
      t2 := Temp.AllocEmpty (Card.T);
      Emit.OpT ("@ = ", t2);
      Emit.OpF ("@_TC->typecode;\n", t);
    ELSE
      t1 := Expr.Compile (args[0]);
      t2 := Temp.AllocEmpty (Card.T);
      Emit.OpTT ("@ = _TYPECODE (@);\n", t2, t1);
      Temp.Free (t1);
    END;
    RETURN t2;
  END Compile;

PROCEDURE Initialize () =
  BEGIN
    Z := CallExpr.NewMethodList (1, 1, TRUE, FALSE, Card.T,
                                 NIL, Check, Compile,
                                 CallExpr.NoValue, (* fold *)
                                 CallExpr.IsNever, (* writable *)
                                 CallExpr.IsNever  (* designator *));
    Procedure.Define ("TYPECODE", Z, TRUE);
  END Initialize;

BEGIN
END Typecode.