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

(* File: ProcType.m3                                           *)
(* Last modified on Tue Jun  9 15:33:38 PDT 1992 by kalsow     *)
(*      modified on Thu Dec  5 17:23:39 PST 1991 by muller     *)

MODULE ProcType;

IMPORT Expr, Type, TypeRep, Value, Scope, String, Target, Error, Frame;
IMPORT Emit, Formal, UserProc, Token, Ident, CallExpr, MBuf, OpenArrayType;
IMPORT ArrayType, RecordType, SetType, Word, Void, M3, ESet, RefType;
FROM Scanner IMPORT Match, GetToken, cur;

TYPE
  P = Type.T BRANDED "ProcType.T" OBJECT
        methods    : CallExpr.MethodList;
        formals    : Scope.T;
        nFormals   : INTEGER;
        result     : Type.T;
        raises     : ESet.T;
      OVERRIDES
        check      := Check;
        base       := TypeRep.SelfBase;
        isEqual    := EqualChk;
        isSubtype  := Subtyper;
        count      := TypeRep.NotOrdinal;
        bounds     := TypeRep.NotBounded;
        size       := Sizer;
        minSize    := Sizer;
        alignment  := Aligner;
	isEmpty    := TypeRep.IsNever;
        dependsOn  := DependsOn;
        compile    := Compiler;
        initCost   := InitCoster;
        initValue  := GenInit;
        paramEncoding := TypeRep.ParamEncUndefined;
        mapper     := GenMap;
        fprint     := FPrinter;
        class      := MyClass;
      END;

PROCEDURE Parse (READONLY fail: Token.Set): Type.T =
  BEGIN
    Match (Token.T.tPROCEDURE, fail, Token.Set {Token.T.tLPAREN});
    RETURN ParseSignature (fail, NIL);
  END Parse;

CONST FormalStart = Token.Set {Token.T.tVALUE, Token.T.tVAR, Token.T.tREADONLY,
                               Token.T.tIDENT, Token.T.tUNUSED};

PROCEDURE ParseSignature (READONLY fail: Token.Set; name: String.T): Type.T =
  TYPE  TK = Token.T;
  VAR   p: P;
  BEGIN
    p := Create (Scope.PushNew (FALSE, name));
    Match (TK.tLPAREN, fail, FormalStart + Token.Set {TK.tRPAREN});
    WHILE (cur.token IN FormalStart) DO
      ParseFormal (p, fail + Token.Set {TK.tSEMI, TK.tRPAREN, TK.tRAISES});
      IF (cur.token # TK.tSEMI) THEN EXIT END;
      GetToken (); (* ; *)
    END;
    Match (TK.tRPAREN, fail, Token.Set {TK.tCOLON, TK.tRAISES});
    IF (cur.token = TK.tCOLON) THEN
      GetToken (); (* : *)
      p.result := Type.Parse (fail + Token.Set {TK.tRAISES});
    END;
    IF (cur.token = TK.tRAISES) THEN
      p.raises := ESet.ParseRaises (fail);
    END;
    Scope.PopNew ();
    RETURN p;
  END ParseSignature;

PROCEDURE ParseFormal (p: P;  READONLY fail: Token.Set) =
  TYPE TK = Token.T;
  VAR
    j, n    : INTEGER;
    obj     : Value.T;
    formal  : Formal.Info;
  BEGIN
    formal.mode   := Formal.Mode.mVALUE;
    formal.type   := NIL;
    formal.dfault := NIL;
    formal.unused := (cur.token = TK.tUNUSED);
    IF (formal.unused) THEN
      GetToken (); (*UNUSED*)
      Match (TK.tENDPRAGMA, fail, Token.Set {TK.tIDENT, TK.tSEMI});
    END;
    IF (cur.token = TK.tVALUE) THEN
      formal.mode := Formal.Mode.mVALUE;
      GetToken (); (* VALUE *)
    ELSIF (cur.token = TK.tVAR) THEN
      formal.mode := Formal.Mode.mVAR;
      GetToken (); (* VAR *)
    ELSIF (cur.token = TK.tREADONLY) THEN
      formal.mode := Formal.Mode.mCONST;
      GetToken (); (* READONLY *)
    END;
    n := Ident.ParseList (fail + Token.Set {TK.tCOLON, TK.tASSIGN});
    IF (cur.token = TK.tCOLON) THEN
      GetToken (); (* : *)
      formal.type := Type.Parse (fail + Token.Set {TK.tASSIGN});
    END;
    IF (cur.token = TK.tEQUAL) THEN
      Error.Msg ("default value must begin with ':='");
      cur.token := TK.tASSIGN;
    END;
    IF (cur.token = TK.tASSIGN) THEN
      GetToken (); (* := *)
      formal.dfault := Expr.Parse (fail);
    END;
    IF (formal.type = NIL) AND (formal.dfault = NIL) THEN
      Error.Str (Ident.stack[Ident.top - 1],
                 "formals must have a type or default value");
    END;
    j := Ident.top - n;
    FOR i := 0 TO n - 1 DO
      formal.name   := Ident.stack [j + i];
      formal.offset := p.nFormals;
      obj := Formal.New (formal);
      obj.origin := Ident.offset[j + i];
      Scope.Insert (obj);
      INC (p.nFormals);
    END;
    DEC (Ident.top, n);
  END ParseFormal;

VAR unnamed: String.T := NIL;

PROCEDURE MethodSigAsProcSig (sig, objType: Type.T): Type.T =
  VAR
    pMethod, pProc: P;
    cnt     : INTEGER;
    f       : Value.T;
    formals : Scope.ValueList;
    names   : Scope.NameList;
    formal  : Formal.Info;
  BEGIN
    TYPECASE Type.Strip (sig) OF 
      | NULL => RETURN NIL;
      | P(p) => pMethod := p;
      ELSE      RETURN NIL;
    END;

    pProc := Create (Scope.PushNew (FALSE, NIL));
    pProc.nFormals  := pMethod.nFormals + 1;
    pProc.result    := pMethod.result;
    pProc.raises    := pMethod.raises;

    (* insert the "self" formal *)
    IF (unnamed = NIL) THEN unnamed := String.Add ("_self_") END;
    formal.name   := unnamed;
    formal.offset := 0;
    formal.mode   := Formal.Mode.mVALUE;
    formal.type   := objType;
    formal.dfault := NIL;
    formal.unused := FALSE;
    Scope.Insert (Formal.New (formal));

    (* copy the remaining formals *)
    Scope.ToListWithAliases (pMethod.formals, formals, cnt, names);
    FOR i := 0 TO cnt - 1 DO
      Formal.Split (formals[i], formal);
      IF (names # NIL) THEN formal.name := names[i] END;
      INC (formal.offset);
      f := Formal.New (formal);
      f.origin := formals[i].origin;
      Scope.Insert (f);
    END;

    Scope.PopNew ();
    RETURN pProc;
  END MethodSigAsProcSig;

PROCEDURE Create (s: Scope.T): P =
  VAR p := NEW (P);
  BEGIN
    TypeRep.Init (p);
    p.methods   := UserProc.Methods;
    p.formals   := s;
    p.nFormals  := 0;
    p.result    := NIL;
    p.raises    := NIL;
    p.hasUntraced := TRUE;
    p.isLocalOnly := TRUE;
    RETURN p;
  END Create;

PROCEDURE MyClass (<*UNUSED*> p: P): TypeRep.Class =
  BEGIN
    RETURN TypeRep.Class.Procedure;
  END MyClass;

PROCEDURE Check (p: P) =
  VAR
    hash: INTEGER;
    n: INTEGER;
    objs: Scope.ValueList; 
    formal: Formal.Info;
    cs := M3.OuterCheckState;
 BEGIN
    (* look up each of the named exceptions *)
    ESet.TypeCheck (p.raises);

    (* add the exceptions to the hash value *)
    hash := ESet.Hash (p.raises);

    (* finish my hash value *)
    Scope.ToList (p.formals, objs, n);
    FOR i := 0 TO n - 1 DO
      Formal.Split (objs[i], formal);
      hash := Word.Plus (Word.Times (hash, 23), String.Hash (formal.name));
      hash := Word.Plus (Word.Times (hash, 37), ORD (formal.mode));
    END;
    p.hash := hash;

    p.checked := TRUE;
    INC (Type.recursionDepth); (*------------------------------------*)
      Scope.TypeCheck (p.formals, cs);
      Type.Check (p.result);
    DEC (Type.recursionDepth); (*------------------------------------*)
  END Check;

PROCEDURE Compiler (p: P) =
  VAR n: INTEGER;  objs: Scope.ValueList;  large := LargeResult (p.result);
  BEGIN
    Type.Compile (p.result);
    IF (large) THEN Type.Compile (Void.T) END;
    IF TypeRep.IsCompiled (p) THEN RETURN END;

    IF (large)
      THEN Emit.Op  ("typedef _VOID ");
      ELSE Emit.OpF ("typedef @ ", p.result);
    END;
    Emit.OpF ("(*@)();\n", p);
    TypeRep.MarkCompiled (p);

    Scope.ToList (p.formals, objs, n);
    FOR i := 0 TO n - 1 DO Value.Declare1 (objs[i]) END;

    IF TypeRep.StartLinkInfo (p) THEN RETURN END;

    Emit.OpF ("d@\n", p.result);
    Emit.Op  ("C\n");
    IF (large)
      THEN Emit.Op  ("typedef _VOID ");
      ELSE Emit.OpF ("typedef @ ", p.result);
    END;
    Emit.OpF ("(*@)();\n", p);
    Emit.Op  ("*\n");
  END Compiler;

PROCEDURE LargeResult (t: Type.T): BOOLEAN =
  VAR index, elem: Type.T; fields: Scope.T;
  BEGIN
    RETURN ArrayType.Split (t, index, elem) OR
           RecordType.Split (t, fields) OR
           SetType.Split (t, elem);
  END LargeResult;

PROCEDURE IsCompatible (procSig, objectType, methodSig: Type.T): BOOLEAN =
  VAR p, q: P;
  BEGIN
    IF NOT Reduce (procSig, p) THEN RETURN FALSE END;
    IF NOT Reduce (methodSig, q) THEN RETURN FALSE END;
    IF (p.nFormals # q.nFormals + 1) THEN RETURN FALSE END;
    IF NOT Type.IsEqual (p.result, q.result, NIL) THEN RETURN FALSE END;
    IF NOT FirstArgOK (p.formals, objectType) THEN RETURN FALSE END;
    IF NOT FormalsMatch (p.formals, q.formals, FALSE, FALSE, NIL) THEN
      RETURN FALSE;
    END;
    RETURN ESet.IsSubset (p.raises, q.raises);
  END IsCompatible;

PROCEDURE FirstArgOK (s: Scope.T;  t: Type.T): BOOLEAN =
  VAR n: INTEGER;  vals: Scope.ValueList;  formal: Formal.Info;
  BEGIN
    Scope.ToList (s, vals, n);
    FOR i := 0 TO n - 1 DO
      Formal.Split (vals[i], formal);
      IF (formal.offset = 0) THEN
        RETURN (formal.mode = Formal.Mode.mVALUE)
           AND Type.IsSubtype (t, formal.type);
      END;
    END;
    RETURN FALSE;
  END FirstArgOK;

PROCEDURE EqualChk (a: P;  t: Type.T;  x: Type.Assumption): BOOLEAN =
  VAR b: P;
  BEGIN
    TYPECASE Type.Strip (t) OF
    | NULL => RETURN FALSE;
    | P(p) => b := p;
    ELSE      RETURN FALSE;
    END;
    IF (a.nFormals # b.nFormals) THEN RETURN FALSE END;
    IF NOT Type.IsEqual (a.result, b.result, x) THEN RETURN FALSE END;
    IF NOT FormalsMatch (a.formals, b.formals, TRUE, TRUE, x) THEN
      RETURN FALSE;
    END;
    RETURN ESet.IsEqual (a.raises, b.raises);
  END EqualChk;

PROCEDURE Subtyper (a: P;  t: Type.T): BOOLEAN =
  VAR b: P;
  BEGIN
    TYPECASE Type.Strip (t) OF
    | NULL => RETURN FALSE;
    | P(p) => b := p;
    ELSE      RETURN FALSE;
    END;
    IF (a.nFormals # b.nFormals) THEN RETURN FALSE END;
    IF NOT Type.IsEqual (a.result, b.result, NIL) THEN RETURN FALSE END;
    IF NOT FormalsMatch (a.formals, b.formals, FALSE, TRUE, NIL) THEN
      RETURN FALSE;
    END;
    RETURN ESet.IsSubset (a.raises, b.raises);
  END Subtyper;

PROCEDURE FormalsMatch (a, b: Scope.T;  strict, useFirst: BOOLEAN;
                         x: Type.Assumption): BOOLEAN =
  VAR
    slots : ARRAY [0..19] OF Formal.Info;
    objs  : Scope.ValueList;
    n     : INTEGER;
  BEGIN
    Scope.ToList (a, objs, n);
    IF (n <= NUMBER (slots)) THEN
      RETURN DoFormalsMatch (a, b, strict, useFirst, x, slots);
    ELSE
      RETURN DoFormalsMatch (a, b, strict, useFirst, x,
                             NEW (REF ARRAY OF Formal.Info, n)^);
    END;
  END FormalsMatch;

PROCEDURE DoFormalsMatch (a, b     : Scope.T;
                          strict   : BOOLEAN;
                          useFirst : BOOLEAN;
                          x        : Type.Assumption;
                      VAR slots    : ARRAY OF Formal.Info): BOOLEAN =
  VAR
    na, nb   : INTEGER;
    objs     : Scope.ValueList;
    fnames   : Scope.NameList;
    e1, e2   : Expr.T;
    formal   : Formal.Info;
  BEGIN
    (* sort the first list of formals *)
    Scope.ToListWithAliases (a, objs, na, fnames);
    IF (na = 0) THEN RETURN TRUE END;
    FOR i := 0 TO na - 1 DO
      Formal.Split (objs[i], formal);
      IF (NOT useFirst) THEN DEC (formal.offset) END;
      IF (formal.offset >= 0) THEN
        WITH z = slots[formal.offset] DO
          z := formal;
          IF (fnames # NIL) THEN z.name := fnames[i] END;
        END;
      END;
    END;
    IF (NOT useFirst) THEN DEC (na) END;

    (* now check that each member of b is in a *)
    Scope.ToListWithAliases (b, objs, nb, fnames);
    IF (na # nb) THEN RETURN FALSE;  END;
    FOR i := 0 TO nb - 1 DO
      Formal.Split (objs[i], formal);
      WITH z = slots[formal.offset] DO
        IF (formal.mode # z.mode) THEN RETURN FALSE END;
        IF NOT Type.IsEqual (formal.type, z.type, x) THEN RETURN FALSE END;
        IF (strict) THEN
          IF (fnames # NIL) THEN formal.name := fnames[i] END;
          IF (formal.name # z.name) THEN RETURN FALSE END;
          e1 := Expr.ConstValue (z.dfault);
          e2 := Expr.ConstValue (formal.dfault);
          IF NOT Expr.IsEqual (e1, e2) THEN RETURN FALSE END;
        END;
      END;
    END;

    RETURN TRUE;
  END DoFormalsMatch;

PROCEDURE Is (t: Type.T): BOOLEAN =
  BEGIN
    RETURN (TYPECODE (Type.Strip (t)) = TYPECODE (P));
  END Is;

PROCEDURE Reduce (t: Type.T;  VAR pp: P): BOOLEAN =
  BEGIN
    TYPECASE Type.Strip (t) OF
    | NULL => RETURN FALSE;
    | P(p) => pp := p; RETURN TRUE;
    ELSE      RETURN FALSE;
    END;
  END Reduce;

PROCEDURE Result (t: Type.T): Type.T =
  BEGIN
    TYPECASE Type.Strip (t) OF
    | NULL => RETURN NIL;
    | P(p) => RETURN p.result;
    ELSE      RETURN NIL;
    END;
  END Result;

PROCEDURE CResult (t: Type.T): Type.T =
  BEGIN
    TYPECASE Type.Strip (t) OF
    | NULL => RETURN NIL;
    | P(p) => IF LargeResult (p.result)
                THEN RETURN Void.T;
                ELSE RETURN p.result;
              END;
    ELSE      RETURN NIL;
    END;
  END CResult;

PROCEDURE Formals (t: Type.T): Scope.T =
  BEGIN
    TYPECASE Type.Strip (t) OF
    | NULL => RETURN NIL;
    | P(p) => RETURN p.formals;
    ELSE      RETURN NIL;
    END;
  END Formals;

PROCEDURE Raises (t: Type.T): M3.ExSet =
  BEGIN
    TYPECASE Type.Strip (t) OF
    | NULL => RETURN NIL;
    | P(p) => RETURN p.raises;
    ELSE      RETURN NIL;
    END;
  END Raises;

PROCEDURE Methods (t: Type.T): CallExpr.MethodList =
  BEGIN
    TYPECASE Type.Strip (t) OF
    | NULL => RETURN NIL;
    | P(p) => RETURN p.methods;
    ELSE      RETURN NIL;
    END;
  END Methods;

PROCEDURE New (READONLY formals: ARRAY OF Value.T;  result: Type.T): Type.T =
  VAR p: P;
  BEGIN
    p := Create (Scope.PushNew (FALSE, NIL));
    FOR i := 0 TO LAST (formals) DO
      IF (formals[i] # NIL) THEN
        Scope.Insert (formals[i]);
	INC (p.nFormals);
      END;
    END;
    p.result := result;
    Scope.PopNew ();
    RETURN p;
  END New;

PROCEDURE CopyValueOpenArrayParameters (signature: Type.T) =
  VAR
    p: P := signature;
    array, elt, ref: Type.T;
    l: Scope.ValueList;
    depth, n: INTEGER;
    block: INTEGER;
  BEGIN
    Scope.ToList (p.formals, l, n);

    (* allocate and copy open arrays passed by value *)
    FOR i := 0 TO n - 1 DO
      ref := Formal.RefOpenArray (l[i]);
      IF (ref # NIL) AND RefType.Split (ref, array) THEN
        array := Type.Base (array);
        elt := OpenArrayType.OpenType (array);
        depth := OpenArrayType.OpenDepth (array);

        (* build the dope vector that describes the array *)
        Frame.PushBlock (block, 4);
        Emit.OpF ("@* _ptr;\n", array);
        Emit.Op  ("int _sz;\n");
        Emit.Op  ("struct {int *elts; int nb_dims;} _sizes;\n");
        Emit.OpN ("_sizes.elts = &(@.size[0]);\n", l[i]);
        Emit.OpI ("_sizes.nb_dims = @;\n", depth);

        (* allocate the storage *)
        Emit.OpFF ("_ptr = (@*) _TNEWA (@_TC, &_sizes);\n", array, ref);

        (* compute the size of the data *)
        Emit.Op  ("_sz = ");
	FOR i := 0 TO depth - 1 DO Emit.OpI ("_sizes.elts[@] * ", i) END;
        Emit.OpI ("@;\n", Type.Size (elt) DIV Target.CHARSIZE);

        (* copy the actual argument into the new storage *)
        Emit.OpN ("_COPY (@.elts, _ptr->elts, _sz);\n", l[i]);
        Emit.OpN ("@.elts = _ptr->elts;\n", l[i]);
        Frame.PopBlock (block);
      END;
    END;
  END CopyValueOpenArrayParameters;


PROCEDURE SetMethods (t: Type.T;  m: CallExpr.MethodList) =
  BEGIN
    NARROW (t, P).methods := m;
  END SetMethods;

PROCEDURE Sizer (<*UNUSED*> t: Type.T): INTEGER =
  BEGIN
    RETURN Target.ADDRSIZE;
  END Sizer;

PROCEDURE Aligner (<*UNUSED*> t: Type.T): INTEGER =
  BEGIN
    RETURN Target.ADDRALIGN;
  END Aligner;

PROCEDURE DependsOn (p: P;  t: Type.T): BOOLEAN =
  BEGIN
    RETURN Type.DependsOn (p.result, t);
  END DependsOn;

PROCEDURE InitCoster (<*UNUSED*> p: P;  zeroed: BOOLEAN): INTEGER =
  BEGIN
    IF (zeroed) THEN RETURN 0 ELSE RETURN 1 END;
  END InitCoster;

PROCEDURE GenInit (p: P) =
  BEGIN
    Emit.OpF ("(@)_NIL", p);
  END GenInit;

PROCEDURE GenMap (<*UNUSED*> p: P;  VAR prefix: String.Stack) =
  BEGIN
    Emit.Op  ("if (_MASK_PROC (_mask)) { ");
    Emit.OpZ ("_p (_arg, &(@), _r, _VAL_PROC); }\n", prefix);
  END GenMap;

PROCEDURE FPrinter (p: P;  map: Type.FPMap;  wr: MBuf.T) =
  VAR elts: Scope.ValueList;  n: INTEGER;
  BEGIN
    MBuf.PutText (wr, "PROC (");
    Scope.ToList (p.formals, elts, n);
    FOR i := 0 TO n - 1 DO Value.Fingerprint (elts[i], map, wr) END;
    MBuf.PutText (wr, ")");
    IF (p.result # NIL) THEN
      MBuf.PutText (wr, " ");
      Type.Fingerprint (p.result, map, wr);
    END;
    ESet.Fingerprint (p.raises, map, wr);
  END FPrinter;

BEGIN
END ProcType.