obliqrt/src/ObValue.m3


Copyright (C) 1994, Digital Equipment Corp.

MODULE ObValue;

IMPORT Text, Fmt, SynWr, SynLocation, ObTree, AtomList, Atom, ObEval, NetObj,
       Pickle, Rd, Wr, Thread, OSError, TextRefTbl, Refany, FileRd, FileWr,
       OpSys;
IMPORT Env AS ProcEnv;

  REVEAL
    RemVarServer =
      RemVar BRANDED "RemVarServer" OBJECT
        val: Val;
      OVERRIDES
        Get := VarGet;
        Set := VarSet;
      END;

   RemArrayServer =
     RemArray BRANDED "RemArrayServer" OBJECT
       array: REF Vals;
     OVERRIDES
       Size := ArraySize;
       Get := ArrayGet;
       Set := ArraySet;
       Sub := ArraySub;
       Upd := ArrayUpd;
       Obtain := ArrayObtain;
     END;

    RemObjServer =
      RemObjServerPublic BRANDED "RemObjServer" OBJECT
        self: ValObj;
        fields: REF ObjFields;
        protected: BOOLEAN;
      OVERRIDES
        Who := ObjWho;
        Select := ObjSelect;
        Invoke := ObjInvoke;
        Update := ObjUpdate;
        Redirect := ObjRedirect;
        Has := ObjHas;
        Obtain := ObjObtain;
      END;

    RemFileSystemServer =
      RemFileSystem BRANDED "RemFileSystemServer" OBJECT
        readOnly: BOOLEAN;
      OVERRIDES
        OpenRead := FileSystemOpenRead;
        OpenWrite := FileSystemOpenWrite;
        OpenAppend := FileSystemOpenAppend;
      END;

VAR
  sysCallTable: TextRefTbl.Default;
This was Luca's original code:

(* -- There should be a better way.

PROCEDURE ThisMachine(): TEXT =
    VAR address: TEXT;
    BEGIN
      address := ProcEnv.Get("MYMACHINE");
      IF (address=NIL) OR Text.Empty(address) THEN
        address:=ProcEnv.Get("MACHINE");
      END;
      IF (address=NIL) OR Text.Empty(address) THEN
        address:="<unknown>";
      END;
      RETURN address;
    END ThisMachine;
*)

  PROCEDURE ThisMachine(): TEXT =
    BEGIN
      TRY
        RETURN OpSys.GetHostName ();
      EXCEPT
      | OpSys.Error => RETURN "<unknown>";
      END;
    END ThisMachine;

  PROCEDURE Setup() =
    BEGIN
      valOk := NEW(ValOk);
      netException := NEW(ValException, name:="net_failure");
      threadAlerted := NEW(ValException, name:="thread_alerted");
      machineAddress := ThisMachine();

      sysCallTable := NEW(TextRefTbl.Default).init();
      sysCallFailure := NEW(ValException, name:="sys_callFailure");
      showNetObjMsgs := FALSE;

      localProcessor := NewProcessor();
      InhibitTransmission(TYPECODE(ValProcessor),
                          "processors cannot be transmitted/duplicated");
    END Setup;

  PROCEDURE RaiseError(msg: TEXT; location: SynLocation.T) RAISES {Error} =
  BEGIN
    RAISE Error(NEW(ErrorPacket, msg:=msg, location:=location));
  END RaiseError;

  PROCEDURE RaiseServerError(msg: TEXT) RAISES {ServerError} =
  BEGIN
    RAISE ServerError(msg);
  END RaiseServerError;

  PROCEDURE SameException(exc1, exc2: ValException): BOOLEAN =
    BEGIN
      RETURN Text.Equal(exc1.name, exc2.name);
    END SameException;

  PROCEDURE RaiseException(exception: ValException; msg: TEXT;
      loc: SynLocation.T) RAISES {Exception} =
    BEGIN
      RAISE Exception(
        NEW(ExceptionPacket, msg:=msg,
            location:=loc, exception:=exception, data:=NIL));
    END RaiseException;

  PROCEDURE RaiseNetException(msg: TEXT; atoms: AtomList.T; loc: SynLocation.T)
    RAISES {Exception} =
  BEGIN
    IF showNetObjMsgs THEN
      msg := msg & " (NetObj says:";
      WHILE atoms # NIL DO
        msg := msg & " " & Atom.ToText(atoms.head);
        atoms := atoms.tail;
      END;
      msg := msg & ")";
    END;
    RaiseException(netException, msg, loc);
  END RaiseNetException;

    PROCEDURE ErrorMsg(swr: SynWr.T; packet: ErrorPacket) =
    BEGIN
      Msg(swr, "Execution error ", packet.msg, packet.location);
    END ErrorMsg;

  PROCEDURE ExceptionMsg(swr: SynWr.T; packet: ExceptionPacket) =
    VAR name: TEXT;
    BEGIN
      name := packet.exception.name;
      IF NOT Text.Empty(packet.msg) THEN
        name := name & " (" & packet.msg & ")";
      END;
      Msg(swr, "Uncaught exception ", name, packet.location);
    END ExceptionMsg;

  PROCEDURE Msg(swr: SynWr.T; msgKind, msg: TEXT;
      sourceLocation: SynLocation.T)  =
    BEGIN
      SynWr.Beg(swr, 2, loud:=TRUE);
        SynWr.Text(swr, msgKind, loud:=TRUE);
        SynLocation.PrintLocation(swr, sourceLocation);
      SynWr.End(swr, loud:=TRUE);
      SynWr.NewLine(swr, loud:=TRUE);

      SynWr.Text(swr, msg, loud:=TRUE);
      SynWr.NewLine(swr, loud:=TRUE);
      SynWr.Flush(swr, loud:=TRUE);
    END Msg;

  PROCEDURE BadOp(pkg, op: TEXT; location: SynLocation.T) RAISES {Error} =
  BEGIN
    RaiseError("Unknown operation: " & pkg & "_" & op, location);
  END BadOp;

  PROCEDURE BadArgType(argNo: INTEGER; expected, pkg, op: TEXT;
    location: SynLocation.T) RAISES {Error} =
  BEGIN
    RaiseError(
      "Argument " & Fmt.Int(argNo) & " of " & pkg & "_" & op
      & " must have type " & expected, location);
  END BadArgType;

  PROCEDURE BadArgVal(argNo: INTEGER; expected, pkg, op: TEXT;
    location: SynLocation.T) RAISES {Error} =
  BEGIN
    RaiseError(
      "Argument " & Fmt.Int(argNo) & " of " & pkg & "_" & op
      & " must be " & expected, location);
  END BadArgVal;

  PROCEDURE NewEnv(name: ObTree.IdeName; env: Env): Env =
  BEGIN
    RETURN NEW(LocalEnv, name:=name, val:=NIL, rest:=env);
  END NewEnv;

  PROCEDURE ExtendEnv(binders: ObTree.IdeList; env: Env): Env =
  BEGIN
    IF binders=NIL THEN RETURN env;
    ELSE RETURN ExtendEnv(binders.rest, NewEnv(binders.first, env));
    END;
  END ExtendEnv;

  PROCEDURE PrintWhat(self: ValAnything): TEXT =
  BEGIN
    RETURN self.what;
  END PrintWhat;

  PROCEDURE IsSelfOther(self, other: ValAnything): BOOLEAN =
  BEGIN
    RETURN self=other;
  END IsSelfOther;

  PROCEDURE Is(v1,v2: Val; <*UNUSED*>location: SynLocation.T): BOOLEAN =
  BEGIN
    TYPECASE v1 OF
    | ValOk =>
        TYPECASE v2 OF
        | ValOk => RETURN TRUE;
        ELSE RETURN FALSE;
        END;
    | ValBool(node1) =>
        TYPECASE v2 OF
        | ValBool(node2) => RETURN node1.bool = node2.bool;
        ELSE RETURN FALSE;
        END;
    | ValChar(node1) =>
        TYPECASE v2 OF
        | ValChar(node2) => RETURN node1.char = node2.char;
        ELSE RETURN FALSE;
        END;
    | ValText(node1) =>
        TYPECASE v2 OF
        | ValText(node2) => RETURN Text.Equal(node1.text, node2.text);
        ELSE RETURN FALSE;
        END;
    | ValException(node1) =>
        TYPECASE v2 OF
        | ValException(node2) => RETURN Text.Equal(node1.name, node2.name);
        ELSE RETURN FALSE;
        END;
    | ValInt(node1) =>
        TYPECASE v2 OF
        | ValInt(node2) => RETURN node1.int = node2.int;
        ELSE RETURN FALSE;
        END;
    | ValReal(node1) =>
        TYPECASE v2 OF
        | ValReal(node2) => RETURN node1.real = node2.real;
        ELSE RETURN FALSE;
        END;
    | ValArray(node1) =>
        TYPECASE v2 OF
        | ValArray(node2) => RETURN node1.remote = node2.remote;
        ELSE RETURN FALSE;
        END;
    | ValAnything(node1) =>
        TYPECASE v2 OF
        | ValAnything(node2) => RETURN node1.Is(node2);
        ELSE RETURN FALSE;
        END;
    | ValOption(node1) =>
        TYPECASE v2 OF
        | ValOption(node2) => RETURN node1 = node2;
        ELSE RETURN FALSE;
        END;
    | ValFun(node1) =>
        TYPECASE v2 OF
        | ValFun(node2) => RETURN node1 = node2;
        ELSE RETURN FALSE;
        END;
    | ValMeth(node1) =>
        TYPECASE v2 OF
        | ValMeth(node2) => RETURN node1 = node2;
        ELSE RETURN FALSE;
        END;
    | ValObj(node1) =>
        TYPECASE v2 OF
        | ValObj(node2) => RETURN node1.remote = node2.remote;
        ELSE RETURN FALSE;
        END;
    | ValAlias(node1) =>
        TYPECASE v2 OF
        | ValAlias(node2) => RETURN node1 = node2;
        ELSE RETURN FALSE;
        END;
    | ValEngine(node1) =>
        TYPECASE v2 OF
        | ValEngine(node2) => RETURN node1.remote = node2.remote;
        ELSE RETURN FALSE;
        END;
    ELSE <*ASSERT FALSE*>
    END;
  END Is;

  PROCEDURE NewText(text: TEXT): Val =
  BEGIN
    IF text=NIL THEN text:="" END;
    RETURN NEW(ValText, text:=text);
  END NewText;

  PROCEDURE NewVar(val: Val): ValVar =
  BEGIN
    RETURN
      NEW(ValVar,
        remote := NEW(RemVarServer, val:=val));
  END NewVar;

  PROCEDURE VarGet(self: RemVarServer): Val RAISES {} =
  BEGIN
    RETURN self.val;
  END VarGet;

  PROCEDURE VarSet(self: RemVarServer; val: Val) RAISES {} =
  BEGIN
    self.val := val;
  END VarSet;

  PROCEDURE NewArray(READONLY vals: Vals): ValArray =
  VAR newVals: REF Vals;
  BEGIN
    newVals := NEW(REF Vals, NUMBER(vals));
    newVals^ := vals;
    RETURN NewArrayFromVals(newVals);
  END NewArray;

  PROCEDURE NewArrayFromVals(vals: REF Vals): ValArray =
  BEGIN
    RETURN
      NEW(ValArray,
        remote := NEW(RemArrayServer, array:=vals));
  END NewArrayFromVals;

  PROCEDURE ArraySize(arr: RemArrayServer): INTEGER RAISES {} =
  BEGIN
    RETURN NUMBER(arr.array^);
  END ArraySize;

  PROCEDURE ArrayGet(self: RemArrayServer; i: INTEGER): Val
    RAISES {ServerError} =
  BEGIN
    IF (i<0) OR (i>=NUMBER(self.array^)) THEN
      RaiseServerError("arg not in range")
    END;
    RETURN self.array^[i];
  END ArrayGet;

  PROCEDURE ArraySet(self: RemArrayServer; i: INTEGER; val: Val)
    RAISES {ServerError} =
  BEGIN
    IF (i<0) OR (i>=NUMBER(self.array^)) THEN
      RaiseServerError("arg 1 not in range");
    END;
    self.array^[i]:=val;
  END ArraySet;

  PROCEDURE ArraySub(self: RemArrayServer; start,size: INTEGER)
    : ValArray RAISES {ServerError} =
  VAR len: INTEGER; vals: REF Vals;
  BEGIN
    len := NUMBER(self.array^);
    IF (start<0) OR (start>len) THEN
      RaiseServerError("arg 2 not in range");
    END;
    IF (size<0) OR (start+size>len) THEN
      RaiseServerError("arg 3 not in range");
    END;
    vals := NEW(REF Vals, size);
    FOR i:=0 TO size-1 DO vals^[i] := self.array^[start+i]; END;
    RETURN NEW(ValArray,
      remote:=NEW(RemArrayServer, array:=vals));
  END ArraySub;

  PROCEDURE ArrayUpd(self: RemArrayServer; start, size: INTEGER;
    READONLY otherArr: REF Vals) RAISES {ServerError, NetObj.Error} =
  VAR selfLen, otherLen: INTEGER; selfArr: REF Vals;
  BEGIN
    selfArr := self.array;
    selfLen := NUMBER(selfArr^);
    IF (start<0) OR (start>selfLen) THEN
      RaiseServerError("arg 2 not in range");
    END;
    IF (size<0) OR (start+size>selfLen) THEN
      RaiseServerError("arg 3 not in range of arg 1");
    END;
    otherLen := NUMBER(otherArr^);
    IF size>otherLen THEN
      RaiseServerError("arg 3 not in range of arg 4");
    END;
    FOR i:=size-1 TO 0 BY -1 DO selfArr^[start+i] := otherArr^[i]; END;
  END ArrayUpd;

  PROCEDURE ArrayObtain(self: RemArrayServer): REF Vals
    RAISES {} =
  BEGIN
    RETURN self.array;
  END ArrayObtain;

  PROCEDURE ArrayCat(vals1, vals2: REF Vals):
    Val RAISES {} =
  VAR len1, len2: INTEGER; vals: REF Vals;
  BEGIN
    len1 := NUMBER(vals1^);
    len2 := NUMBER(vals2^);
    vals := NEW(REF Vals, len1+len2);
    FOR i:=0 TO len1-1 DO vals^[i] := vals1^[i]; END;
    FOR i:=0 TO len2-1 DO vals^[len1+i] := vals2^[i]; END;
    RETURN NEW(ValArray, remote:=NEW(RemArrayServer, array:=vals));
  END ArrayCat;

  PROCEDURE NewObject(READONLY fields: ObjFields;
    who: TEXT:=""; protected: BOOLEAN:=FALSE; sync: Sync:=NIL): ValObj =
  VAR remFields: REF ObjFields;
  BEGIN
    remFields := NEW(REF ObjFields, NUMBER(fields));
    remFields^ := fields;
    RETURN NewObjectFromFields(remFields, who, protected, sync);
  END NewObject;

  PROCEDURE NewObjectFromFields(fields: REF ObjFields;
    who: TEXT; protected: BOOLEAN; sync: Sync): ValObj =
  VAR remObjServ: RemObjServer;
  BEGIN
    remObjServ :=
      NEW(RemObjServer,
        who:=who,
        self:=NEW(ValObj, remote:=NIL),
        fields:=fields,
        protected := protected,
        sync := sync);
    remObjServ.self.remote := remObjServ;
    RETURN remObjServ.self;
  END NewObjectFromFields;

  PROCEDURE ObjWho(self: RemObjServer;
    VAR(*out*) protected, serialized: BOOLEAN): TEXT RAISES {} =
  BEGIN
    protected := self.protected;
    serialized := self.sync # NIL;
    RETURN self.who;
  END ObjWho;

  PROCEDURE ObjClone1(remObj: RemObj; mySelf: RemObj): ValObj
      RAISES {ServerError, NetObj.Error} =
    VAR res: RemObjServer; resWho, remWho: TEXT;
    VAR fieldsOf1: REF ObjFields;
    VAR resSize: INTEGER; resFields: REF ObjFields;
    VAR protected, serialized: BOOLEAN; sync: Sync;
  BEGIN
    remWho := remObj.Who((*out*)protected, (*out*) serialized);
    IF Text.Empty(remWho) THEN remWho := "someone" END;
    resWho := "clone of " & remWho;
    fieldsOf1 := remObj.Obtain(remObj=mySelf);
    resSize := NUMBER(fieldsOf1^);
    resFields := NEW(REF ObjFields, resSize);
    resFields^ := fieldsOf1^;
    IF serialized THEN sync := NEW(Sync, mutex:=NEW(Thread.Mutex))
    ELSE sync:=NIL
    END;
    res := NEW(RemObjServer,
      who:=resWho,
      self:=NEW(ValObj, remote:=NIL),
      fields:=resFields,
      protected := protected,
      sync := sync);
    res.self.remote := res;
    RETURN res.self;
  END ObjClone1;

  PROCEDURE ObjClone(READONLY remObjs: ARRAY OF RemObj; mySelf: RemObj): ValObj
      RAISES {ServerError, NetObj.Error} =
    VAR res: RemObjServer; resWho, remWho: TEXT;
    VAR fieldsOfN: REF ARRAY OF REF ObjFields;
    VAR resSize,k: INTEGER; ithFields, resFields: REF ObjFields;
    VAR protected, protected1, serialized, serialized1: BOOLEAN; sync: Sync;
  BEGIN
    resWho := "clone of";
    protected := FALSE; serialized := FALSE;
    fieldsOfN := NEW(REF ARRAY OF REF ObjFields, NUMBER(remObjs));
    FOR i:=0 TO NUMBER(remObjs)-1 DO
      remWho := remObjs[i].Who((*out*)protected1, (*out*)serialized1);
      IF i=0 THEN
        protected := protected1; serialized := serialized1;
      END;
      IF Text.Empty(remWho) THEN remWho := "someone" END;
      resWho := resWho & " " & remWho;
      fieldsOfN^[i] := remObjs[i].Obtain(remObjs[i]=mySelf);
    END;
    resSize := 0;
    FOR i:=0 TO NUMBER(fieldsOfN^)-1 DO
      ithFields := fieldsOfN^[i];
      INC(resSize, NUMBER(ithFields^));
    END;
    resFields := NEW(REF ObjFields, resSize);
    k := 0;
    FOR i:=0 TO NUMBER(fieldsOfN^)-1 DO
      ithFields := fieldsOfN^[i];
      FOR j:=0 TO NUMBER(ithFields^)-1 DO
        resFields^[k] := ithFields^[j];
        INC(k);
      END;
    END;
    IF NUMBER(fieldsOfN^) > 1 THEN
      FOR i:=0 TO resSize-1 DO
        FOR j:=i+1 TO resSize-1 DO
          IF Text.Equal(resFields^[i].label, resFields^[j].label) THEN
              RaiseServerError(
                "duplicated field on cloning: " & resFields^[i].label);
          END;
        END;
      END;
    END;
    IF serialized THEN sync := NEW(Sync, mutex:=NEW(Thread.Mutex))
    ELSE sync:=NIL
    END;
    res := NEW(RemObjServer,
      who:=resWho,
      self:=NEW(ValObj, remote:=NIL),
      fields:=resFields,
      protected := protected,
      sync := sync);
    res.self.remote := res;
    RETURN res.self;
  END ObjClone;

  PROCEDURE BadArgsNoMsg(desired, found: INTEGER;
      routineKind, routineName: TEXT): TEXT =
    VAR msg: TEXT;
    BEGIN
      msg := "Expecting " & Fmt.Int(desired);
      IF desired=1 THEN
        msg := msg & " argument";
      ELSE
        msg := msg & " arguments";
      END;
      msg := msg & ", not " & Fmt.Int(found);
      IF NOT Text.Empty(routineKind) THEN
        msg := msg & ", for " & routineKind & ": " & routineName;
      END;
      RETURN  msg;
    END BadArgsNoMsg;

  PROCEDURE ObjSelect(self: RemObjServer; label: TEXT;
    internal: BOOLEAN; VAR (*in-out*) hint: INTEGER): Val
    RAISES {ServerError, Error, Exception, NetObj.Error} =
  VAR lock: BOOLEAN; fields: REF ObjFields; newEnv: Env;
    fieldsNo, fieldIndex: INTEGER; fieldVal: Val; objMu: Thread.Mutex;
  BEGIN
    lock := (NOT internal) AND (self.sync # NIL);
    IF lock THEN objMu:=self.sync.mutex; Thread.Acquire(objMu) END;
    TRY

      fields := self.fields;
      fieldsNo := NUMBER(fields^);
      fieldIndex := -1;
      IF (hint>=0) AND (hint<fieldsNo) AND Text.Equal(label, fields^[hint].label)
      THEN fieldIndex := hint;
      ELSE
        FOR i:=0 TO fieldsNo-1 DO
          IF Text.Equal(label, fields^[i].label) THEN
            fieldIndex := i; EXIT;
          END;
        END;
        IF fieldIndex=-1 THEN
          RaiseServerError("Field not found in object: " & label);
        END;
        hint := fieldIndex;
      END;
      fieldVal := fields^[fieldIndex].field;

      TYPECASE fieldVal OF
      | ValMeth(meth) =>
          (* Consider a method with zero parameters as a field. *)
          IF meth.meth.bindersNo-1 # 0 THEN
            RaiseServerError(
              BadArgsNoMsg(meth.meth.bindersNo-1, 0, "method", label));
          END;
	  newEnv := NEW(LocalEnv, name:=meth.meth.binders.first,
	    val:=self.self, rest:=NIL);
          RETURN ObEval.Term(meth.meth.body, (*in-out*)newEnv, meth.global, self);
      | ValAlias(alias) =>
          TYPECASE alias.obj OF
          | ValObj(valObj) =>
              RETURN valObj.remote.Select(alias.label, valObj.remote=self,
                (*var*)alias.labelIndexHint);
          END;
      ELSE RETURN fieldVal;
      END;

    FINALLY IF lock THEN Thread.Release(objMu) END;
    END;
  END ObjSelect;

  PROCEDURE ObjHas(self: RemObjServer; label: TEXT; VAR hint: INTEGER)
    : BOOLEAN RAISES {NetObj.Error} =
  VAR fields: REF ObjFields;
  BEGIN
    fields := self.fields;
    FOR i:=0 TO NUMBER(fields^)-1 DO
        IF Text.Equal(label, fields^[i].label) THEN
          hint := i;
          RETURN TRUE;
        END;
    END;
    RETURN FALSE;
  END ObjHas;

  PROCEDURE ObjInvoke(self: RemObjServer; label: TEXT;
    argsNo: INTEGER; READONLY args: Vals; internal: BOOLEAN;
    VAR (*in-out*) hint: INTEGER): Val
    RAISES {ServerError, Error, Exception, NetObj.Error} =
  VAR lock: BOOLEAN; fields: REF ObjFields; binderList: ObTree.IdeList;
    newEnv: Env; fieldsNo, fieldIndex: INTEGER; fieldVal: Val;
    objMu: Thread.Mutex;
  BEGIN
    lock := (NOT internal) AND (self.sync # NIL);
    IF lock THEN objMu:=self.sync.mutex; Thread.Acquire(objMu) END;
    TRY

      fields := self.fields;
      fieldsNo := NUMBER(fields^);
      fieldIndex := -1;
      IF (hint>=0) AND (hint<fieldsNo) AND
          Text.Equal(label, fields^[hint].label) THEN
        fieldIndex := hint;
      ELSE
        FOR i:=0 TO fieldsNo-1 DO
          IF Text.Equal(label, fields^[i].label) THEN
            fieldIndex := i; EXIT;
          END;
        END;
        IF fieldIndex=-1 THEN
          RaiseServerError("Field not found in object: " & label);
        END;
        hint := fieldIndex;
      END;
      fieldVal := fields^[fieldIndex].field;

      TYPECASE fieldVal OF
      | ValMeth(meth) =>
          IF meth.meth.bindersNo-1 # argsNo THEN
            RaiseServerError(
              BadArgsNoMsg(meth.meth.bindersNo-1, argsNo, "method", label));
          END;
          binderList := meth.meth.binders;
	      newEnv :=
	        NEW(LocalEnv, name:=binderList.first, val:=self.self, rest:=NIL);
              binderList := binderList.rest;
          FOR i:=0 TO argsNo-1 DO
            newEnv := NEW(LocalEnv, name:=binderList.first,
	          val:=args[i], rest:=newEnv);
	        binderList := binderList.rest;
          END;
	      RETURN
	        ObEval.Term(meth.meth.body, (*in-out*)newEnv, meth.global, self);
      | ValAlias(alias) =>
        TYPECASE alias.obj OF
        | ValObj(valObj) =>
            RETURN valObj.remote.Invoke(alias.label, argsNo, args,
              valObj.remote=self, (*in-out*)alias.labelIndexHint);
        END;
      ELSE RaiseServerError("Field used as a method: " & label); <*ASSERT FALSE*>
      END;

    FINALLY IF lock THEN Thread.Release(objMu) END;
    END;
  END ObjInvoke;

  PROCEDURE ObjUpdate(self: RemObjServer; label: TEXT; val: Val;
    internal: BOOLEAN; VAR (*in-out*) hint: INTEGER)
    RAISES {ServerError, NetObj.Error} =
  VAR lock: BOOLEAN; fields: REF ObjFields; fieldsNo, fieldIndex: INTEGER;
    objMu: Thread.Mutex;
  BEGIN
    lock := (NOT internal) AND (self.sync # NIL);
    IF lock THEN objMu:=self.sync.mutex; Thread.Acquire(objMu) END;
    TRY

      IF self.protected AND (NOT internal) THEN
        RaiseServerError("Cannot update protected object");
      END;
      fields := self.fields;
      fieldsNo := NUMBER(fields^);
      fieldIndex := -1;
      IF (hint>=0) AND (hint<fieldsNo) AND Text.Equal(label, fields^[hint].label)
      THEN fieldIndex := hint;
      ELSE
        FOR i:=0 TO fieldsNo-1 DO
          IF Text.Equal(label, fields^[i].label) THEN
            fieldIndex := i; EXIT;
          END;
        END;
        IF fieldIndex=-1 THEN
          RaiseServerError("Field not found in object: " & label);
        END;
        hint := fieldIndex;
      END;

      TYPECASE fields^[fieldIndex].field OF
      | ValAlias(alias) =>
        TYPECASE alias.obj OF
        | ValObj(valObj) =>
            TYPECASE val OF
            | ValAlias => fields^[fieldIndex].field := val
            ELSE valObj.remote.Update(alias.label, val, valObj.remote=self,
                (*in-out*)alias.labelIndexHint);
            END;
        END;
      ELSE fields^[fieldIndex].field := val;
      END;

    FINALLY IF lock THEN Thread.Release(objMu) END;
    END;
  END ObjUpdate;

  PROCEDURE ObjRedirect(self: RemObjServer; val: Val;
    internal: BOOLEAN) RAISES {ServerError, NetObj.Error} =
  VAR lock: BOOLEAN; fields, newFields: REF ObjFields; fieldsNo: INTEGER;
      label: TEXT; hint: INTEGER; objMu: Thread.Mutex;
  BEGIN
    lock := (NOT internal) AND (self.sync # NIL);
    IF lock THEN objMu:=self.sync.mutex; Thread.Acquire(objMu) END;
    TRY

      IF self.protected AND (NOT internal) THEN
        RaiseServerError("Cannot redirect protected object");
      END;
      fields := self.fields;
      fieldsNo := NUMBER(fields^);
      newFields := NEW(REF ObjFields, fieldsNo);
      TYPECASE val OF
      | ValObj(obj) =>
          FOR i:=0 TO fieldsNo-1 DO
            label := fields^[i].label;
            newFields^[i].label := label;
            IF obj.remote.Has(label, (*in-out*)hint) THEN
              newFields^[i].field :=
                NEW(ValAlias, label:=label, labelIndexHint := hint, obj:=obj);
            ELSE RaiseServerError("Field not found in object on redirection: "
              & label);
            END;
          END;
          self.fields := newFields; (* atomic swap *)
      ELSE RaiseServerError("Redirection target must be an object");
      END;

    FINALLY IF lock THEN Thread.Release(objMu) END;
    END;
  END ObjRedirect;

  PROCEDURE ObjObtain(self: RemObjServer; internal: BOOLEAN): REF ObjFields
    RAISES {ServerError, NetObj.Error} =
  VAR lock: BOOLEAN; objMu: Thread.Mutex;
  BEGIN
    lock := (NOT internal) AND (self.sync # NIL);
    IF lock THEN objMu:=self.sync.mutex; Thread.Acquire(objMu) END;
    TRY

      IF self.protected AND (NOT internal) THEN
        RaiseServerError("Cannot obtain protected object");
      END;
      RETURN self.fields;

    FINALLY IF lock THEN Thread.Release(objMu) END;
    END;
  END ObjObtain;

  PROCEDURE NewAlias(obj: ValObj; label: TEXT;location: SynLocation.T)
    : ValAlias RAISES {Error, Exception} =
  VAR hint: INTEGER;
  BEGIN
    TRY
      IF obj.remote.Has(label, (*var*)hint) THEN
        RETURN
          NEW(ValAlias, label:=label,
            labelIndexHint := hint, obj:=obj);
      ELSE
        RaiseError("Field not found in object: " & label, location); <*ASSERT FALSE*>
      END;
    EXCEPT
    | NetObj.Error(atoms) =>
       RaiseNetException("on remote object access", atoms, location); <*ASSERT FALSE*>
    END;
  END NewAlias;

  PROCEDURE EngineWho(self: RemEngineServer): TEXT RAISES {} =
  BEGIN
    RETURN self.who;
  END EngineWho;

  PROCEDURE EngineEval(self: RemEngineServer; proc: Val; mySelf: RemObj)
    : Val RAISES {Error, Exception, ServerError, NetObj.Error} =
  VAR newEnv: Env; newGlob: GlobalEnv;
  BEGIN
    TYPECASE proc OF
    | ValFun(clos) =>
       IF 1 # clos.fun.bindersNo THEN
         RaiseServerError("Engine needs a procedure of 1 argument as argument");
        END;
        newGlob := clos.global;
        newEnv := NEW(LocalEnv, name:=clos.fun.binders.first,
	            val:=self.arg, rest:=NIL);
        RETURN ObEval.Term(clos.fun.body,
	    (*in-out*)newEnv, newGlob, mySelf);
    ELSE RaiseServerError("Engine needs a procedure as argument"); <*ASSERT FALSE*>
    END;
  END EngineEval;

  PROCEDURE NewFileSystem(readOnly: BOOLEAN): ValFileSystem =
  BEGIN
    RETURN
      NEW(ValFileSystem,
          picklable := FALSE,
          what:="<FileSystem at " & machineAddress & ">",
          remote := NEW(RemFileSystemServer, readOnly:=readOnly));
  END NewFileSystem;

  PROCEDURE FileSystemIs(self: ValFileSystem; other: ValAnything): BOOLEAN =
  BEGIN
    TYPECASE other OF
    | ValFileSystem(oth) =>
      RETURN self.remote = oth.remote;
    ELSE RETURN FALSE;
    END;
  END FileSystemIs;

  PROCEDURE FileSystemOpenRead(<*UNUSED*>self: RemFileSystemServer; fileName: TEXT)
    : Rd.T RAISES {NetObj.Error, ServerError} =
  BEGIN
    TRY RETURN FileRd.Open(fileName);
    EXCEPT OSError.E => RaiseServerError("FileSystemOpenRead"); <*ASSERT FALSE*> END;
  END FileSystemOpenRead;

  PROCEDURE FileSystemOpenWrite(self: RemFileSystemServer; fileName: TEXT)
    : Wr.T RAISES {NetObj.Error, ServerError} =
  BEGIN
    IF self.readOnly THEN RaiseServerError("FileSystemOpenWrite") END;
    TRY RETURN FileWr.Open(fileName);
    EXCEPT OSError.E => RaiseServerError("FileSystemOpenWrite"); <*ASSERT FALSE*> END;
  END FileSystemOpenWrite;

  PROCEDURE FileSystemOpenAppend(self: RemFileSystemServer; fileName: TEXT)
    : Wr.T RAISES {NetObj.Error, ServerError} =
  BEGIN
    IF self.readOnly THEN RaiseServerError("FileSystemOpenAppend") END;
    TRY RETURN FileWr.OpenAppend(fileName);
    EXCEPT OSError.E => RaiseServerError("FileSystemOpenAppend"); <*ASSERT FALSE*> END;
  END FileSystemOpenAppend;

  PROCEDURE NewProcessor(): ValProcessor =
  BEGIN
    RETURN
      NEW(ValProcessor,
          picklable := FALSE,
          what:="<Processor at " & machineAddress & ">");
  END NewProcessor;

  PROCEDURE RegisterSysCall(name: TEXT; clos: SysCallClosure) =
  VAR v: Refany.T;
  BEGIN
    IF clos = NIL THEN EVAL sysCallTable.delete(name, (*out*)v);
    ELSE EVAL sysCallTable.put(name, clos);
    END;
  END RegisterSysCall;

  PROCEDURE FetchSysCall(name: TEXT; VAR(*out*) clos: SysCallClosure): BOOLEAN =
  VAR v: Refany.T; found: BOOLEAN;
  BEGIN
    found := sysCallTable.get(name, (*out*)v);
    clos := NARROW(v, SysCallClosure);
    RETURN found;
  END FetchSysCall;

  (* === GC-safe hash table of refanys :-) === *)

  TYPE TblArr = ARRAY OF RECORD old,new: REFANY END;
  REVEAL Tbl =
    BRANDED OBJECT
      a: REF TblArr;
      top: INTEGER := 0;
    METHODS
      Get(old: REFANY; VAR(*out*) new: REFANY): BOOLEAN := TblGet;
      Put(old, new: REFANY) := TblPut;
    END;

  PROCEDURE NewTbl(): Tbl =
  BEGIN
    RETURN NEW(Tbl, a:=NEW(REF TblArr, 256), top:=0);
  END NewTbl;

  PROCEDURE TblGet(self: Tbl; old: REFANY; VAR(*out*) new: REFANY): BOOLEAN =
  BEGIN
    FOR i := self.top-1 TO 0 BY -1 DO
      IF self.a^[i].old = old THEN new := self.a^[i].new; RETURN TRUE END;
    END;
    RETURN FALSE;
  END TblGet;

  PROCEDURE TblPut(self: Tbl; old, new: REFANY) =
  VAR newArr: REF TblArr;
  BEGIN
    self.a^[self.top].old := old;
    self.a^[self.top].new := new;
    INC(self.top);
    IF self.top >= NUMBER(self.a^) THEN
      newArr := NEW(REF TblArr, 2*NUMBER(self.a^));
      SUBARRAY(newArr^, 0, NUMBER(self.a^)) := self.a^;
      self.a := newArr;
    END;
  END TblPut;

  (* === Copy === *)

  TYPE CopyStyle = {ValToVal, ValToLocal, LocalToVal};

  TYPE ValVarLocal =
    Val BRANDED "ValVarLocal" OBJECT
      val: Val;
    END;

  TYPE ValArrayLocal =
    Val BRANDED "ValArrayLocal" OBJECT
      array: REF Vals;
    END;

  TYPE ValObjLocal =
    Val BRANDED "ValObjLocal" OBJECT
      who: TEXT;
      fields: REF ObjFields;
      protected, serialized: BOOLEAN;
    END;

  PROCEDURE CopyVal(val: Val; tbl: Tbl; loc: SynLocation.T)
    : Val RAISES {Error, NetObj.Error} =
  BEGIN
    RETURN Copy(val, tbl, loc, CopyStyle.ValToVal);
  END CopyVal;

  PROCEDURE CopyValToLocal(val: Val; tbl: Tbl; loc: SynLocation.T)
    : Val RAISES {Error, NetObj.Error} =
  BEGIN
    RETURN Copy(val, tbl, loc, CopyStyle.ValToLocal);
  END CopyValToLocal;

  PROCEDURE CopyLocalToVal(val: Val; tbl: Tbl; loc: SynLocation.T)
    : Val RAISES {Error, NetObj.Error} =
  BEGIN
    RETURN Copy(val, tbl, loc, CopyStyle.LocalToVal);
  END CopyLocalToVal;

  PROCEDURE Copy(val: Val; tbl: Tbl; loc: SynLocation.T; style: CopyStyle)
    : Val RAISES {Error, NetObj.Error} =
  VAR cache: REFANY;
  BEGIN
    TYPECASE val OF
    | ValVar(node) =>
      VAR newVar: ValVar; newVarLocal: ValVarLocal;
      BEGIN
        IF tbl.Get(node.remote, (*out*)cache) THEN RETURN cache END;
        CASE style OF
        | CopyStyle.ValToVal =>
            newVar := NEW(ValVar, remote := NIL);
            tbl.Put(node.remote, newVar);
            newVar.remote :=
              NEW(RemVarServer, val:=Copy(node.remote.Get(), tbl, loc, style));
            RETURN newVar;
        | CopyStyle.ValToLocal =>
            newVarLocal := NEW(ValVarLocal, val := NIL);
            tbl.Put(node.remote, newVarLocal);
            newVarLocal.val := Copy(node.remote.Get(), tbl, loc, style);
            RETURN newVarLocal;
        ELSE <*ASSERT FALSE*>
        END;
      END;
    | ValVarLocal(node) =>
      VAR newVar: ValVar;
      BEGIN
        IF tbl.Get(node, (*out*)cache) THEN RETURN cache END;
        CASE style OF
        | CopyStyle.LocalToVal =>
            newVar := NEW(ValVar, remote := NIL);
            tbl.Put(node, newVar);
            newVar.remote :=
              NEW(RemVarServer, val:=Copy(node.val, tbl, loc, style));
            RETURN newVar;
        ELSE <*ASSERT FALSE*>
        END;
      END;
    | ValOk, ValBool, ValChar, ValText, ValInt, ValReal, ValException,
        ValEngine => RETURN val;
    | ValOption(node) =>
      VAR newOpt: ValOption;
      BEGIN
        IF tbl.Get(node, (*out*)cache) THEN RETURN cache END;
        newOpt := NEW(ValOption, tag:=node.tag, val:=NIL);
        tbl.Put(node, newOpt);
        newOpt.val := Copy(node.val, tbl, loc, style);
        RETURN newOpt;
      END;
    | ValAlias(node) =>
      VAR newAlias: ValAlias;
      BEGIN
        IF tbl.Get(node, (*out*)cache) THEN RETURN cache END;
        newAlias := NEW(ValAlias, label:=node.label,
          labelIndexHint:=node.labelIndexHint, obj:=NIL);
        tbl.Put(node, newAlias);
        newAlias.obj := Copy(node.obj, tbl, loc, style);
        RETURN newAlias;
      END;
    | ValArray(node) =>
      VAR vals, newVals: REF Vals;
          newArr: ValArray; newArrLocal: ValArrayLocal;
      BEGIN
        IF tbl.Get(node.remote, (*out*)cache) THEN RETURN cache END;
        vals := node.remote.Obtain();
        newVals := NEW(REF Vals, NUMBER(vals^));
        CASE style OF
        | CopyStyle.ValToVal =>
            newArr := NEW(ValArray, remote:=NIL);
            tbl.Put(node.remote, newArr);
            FOR i := 0 TO NUMBER(vals^)-1 DO
              newVals^[i] := Copy(vals^[i], tbl, loc, style);
            END;
            newArr.remote := NEW(RemArrayServer, array:=newVals);
            RETURN newArr;
        | CopyStyle.ValToLocal =>
            newArrLocal := NEW(ValArrayLocal, array:=NIL);
            tbl.Put(node.remote, newArrLocal);
            FOR i := 0 TO NUMBER(vals^)-1 DO
              newVals^[i] := Copy(vals^[i], tbl, loc, style);
            END;
            newArrLocal.array := newVals;
            RETURN newArrLocal;
        ELSE <*ASSERT FALSE*>
        END;
      END;
    | ValArrayLocal(node) =>
      VAR vals, newVals: REF Vals; newArr: ValArray;
      BEGIN
        IF tbl.Get(node, (*out*)cache) THEN RETURN cache END;
        vals := node.array;
        newVals := NEW(REF Vals, NUMBER(vals^));
        CASE style OF
        | CopyStyle.LocalToVal =>
            newArr := NEW(ValArray, remote:=NIL);
            tbl.Put(node, newArr);
            FOR i := 0 TO NUMBER(vals^)-1 DO
              newVals^[i] := Copy(vals^[i], tbl, loc, style);
            END;
            newArr.remote := NEW(RemArrayServer, array:=newVals);
            RETURN newArr;
        ELSE <*ASSERT FALSE*>
        END;
      END;
    | ValAnything(node) =>
        CASE style OF
        | CopyStyle.ValToVal =>
            RETURN node.Copy(tbl, loc);
        | CopyStyle.ValToLocal, CopyStyle.LocalToVal =>
            IF node.picklable THEN RETURN node
            ELSE RaiseError("Cannot pickle: " & node.what, loc); <*ASSERT FALSE*>
            END;
        ELSE <*ASSERT FALSE*>
        END;
    | ValFun(node) =>
      VAR newProc: ValFun;
      BEGIN
        IF tbl.Get(node, (*out*)cache) THEN RETURN cache END;
        newProc := NEW(ValFun, fun:=node.fun,
          global:=NEW(REF Vals, NUMBER(node.global^)));
        tbl.Put(node, newProc);
        FOR i := 0 TO NUMBER(node.global^)-1 DO
          newProc.global^[i] := Copy(node.global^[i], tbl,loc, style);
        END;
        RETURN newProc;
      END;
    | ValMeth(node) =>
      VAR newMeth: ValMeth;
      BEGIN
        IF tbl.Get(node, (*out*)cache) THEN RETURN cache END;
        newMeth := NEW(ValMeth, meth:=node.meth,
          global:=NEW(REF Vals, NUMBER(node.global^)));
        tbl.Put(node, newMeth);
        FOR i := 0 TO NUMBER(node.global^)-1 DO
          newMeth.global^[i] := Copy(node.global^[i], tbl, loc, style);
        END;
        RETURN newMeth;
      END;
    | ValObj(node) =>
      VAR newObj: ValObj; newObjLocal: ValObjLocal; newObjServ: RemObjServer;
          fields, newFields: REF ObjFields;
          who: TEXT; protected, serialized: BOOLEAN; sync: Sync;
      BEGIN
        IF tbl.Get(node.remote, (*out*)cache) THEN RETURN cache END;
        TRY
          who := node.remote.Who((*out*)protected, (*out*)serialized);
          fields := node.remote.Obtain(FALSE);
          newFields := NEW(REF ObjFields, NUMBER(fields^));
        EXCEPT ServerError(msg) => RaiseError(msg, loc);
        END;
        IF serialized THEN sync := NEW(Sync, mutex:=NEW(Thread.Mutex))
        ELSE sync:=NIL
        END;
        CASE style OF
        | CopyStyle.ValToVal =>
            newObj := NEW(ValObj, remote:=NIL);
            tbl.Put(node.remote, newObj);
            FOR i := 0 TO NUMBER(fields^)-1 DO
              newFields^[i].label := fields^[i].label;
              newFields^[i].field := Copy(fields^[i].field, tbl, loc, style);
            END;
            newObjServ :=
              NEW(RemObjServer, who:=who, self:=NIL, fields := newFields,
                protected := protected, sync := sync);
            newObj.remote := newObjServ;
            newObjServ.self := newObj;
            RETURN newObj;
        | CopyStyle.ValToLocal =>
            newObjLocal := NEW(ValObjLocal, who:=who, fields:=NIL,
                protected:=protected, serialized:=serialized);
            tbl.Put(node.remote, newObjLocal);
            FOR i := 0 TO NUMBER(fields^)-1 DO
              newFields^[i].label := fields^[i].label;
              newFields^[i].field := Copy(fields^[i].field, tbl, loc, style);
            END;
            newObjLocal.fields := newFields;
            RETURN newObjLocal;
	    ELSE <*ASSERT FALSE*>
        END;
      END;
    | ValObjLocal(node) =>
      VAR newObj: ValObj; newObjServ: RemObjServer;
          fields, newFields: REF ObjFields; sync: Sync;
      BEGIN
        IF tbl.Get(node, (*out*)cache) THEN RETURN cache END;
        fields := node.fields;
        newFields := NEW(REF ObjFields, NUMBER(fields^));
        IF node.serialized THEN sync := NEW(Sync, mutex:=NEW(Thread.Mutex))
        ELSE sync:=NIL
        END;
        CASE style OF
        | CopyStyle.LocalToVal =>
            newObj := NEW(ValObj, remote:=NIL);
            tbl.Put(node, newObj);
            FOR i := 0 TO NUMBER(fields^)-1 DO
              newFields^[i].label := fields^[i].label;
              newFields^[i].field := Copy(fields^[i].field, tbl, loc, style);
            END;
            newObjServ :=
              NEW(RemObjServer, who:=node.who, self:=NIL, fields := newFields,
                protected := node.protected, sync := sync);
            newObj.remote := newObjServ;
            newObjServ.self := newObj;
            RETURN newObj;
        ELSE <*ASSERT FALSE*>
        END;
      END;
    ELSE <*ASSERT FALSE*>
    END;
  END Copy;

  PROCEDURE CopyId(self: ValAnything; <*UNUSED*>tbl: Tbl; <*UNUSED*>loc: SynLocation.T)
    : ValAnything =
  BEGIN
    RETURN self;
  END CopyId;

  PROCEDURE CopyError(self: ValAnything; <*UNUSED*>tbl: Tbl;
    loc: SynLocation.T): ValAnything RAISES {Error} =
  BEGIN
    RaiseError("Cannot copy: " & self.what, loc); <*ASSERT FALSE*>
  END CopyError;

  TYPE
    InhibitSpecial =
      Pickle.Special OBJECT
        reason: TEXT;
        OVERRIDES
          write := WriteInhibitTransmission;
          read := ReadInhibitTransmission;
        END;

  PROCEDURE WriteInhibitTransmission(self: InhibitSpecial; <*UNUSED*>ref: REFANY;
    <*UNUSED*>wr: Pickle.Writer) RAISES {Pickle.Error, Wr.Failure, Thread.Alerted} =
  BEGIN
    RAISE Pickle.Error(self.reason);
  END WriteInhibitTransmission;

  PROCEDURE ReadInhibitTransmission(self: InhibitSpecial;
    <*UNUSED*>rd: Pickle.Reader; <*UNUSED*>id: Pickle.RefID): REFANY
    RAISES {Pickle.Error, Rd.EndOfFile, Rd.Failure, Thread.Alerted} =
  BEGIN
    RAISE Pickle.Error(self.reason);
  END ReadInhibitTransmission;

  PROCEDURE InhibitTransmission(tc: INTEGER; reason: TEXT) =
  BEGIN
    Pickle.RegisterSpecial(NEW(InhibitSpecial, sc:=tc, reason:=reason));
  END InhibitTransmission;

BEGIN
END ObValue.
-- This was an attempt to convince the NetObj runtime to do the right thing on pickling. Has been replaced by the current obliq pickling code, using Copy.

There should be a way to temporarily register specials for NetObj.T's. The array of specials should be a parameter to Pickle.Read/Pickle.Write.

In Setup: Pickle.RegisterSpecial(NEW(ValArraySpecial, sc:=TYPECODE(ValArray)));

TYPE ValArraySpecial = Pickle.Special OBJECT OVERRIDES write := WriteValArray; read := ReadValArray; END;

PROCEDURE WriteValArray(self: ValArraySpecial; ref: REFANY; wr: Pickle.Writer) RAISES {Pickle.Error, Wr.Failure, Thread.Alerted} = BEGIN TYPECASE ref OF

      ValArray(valArray) =>
      
TYPECASE valArray.remote OF
      RemArrayServer(remArrayServer) =>
          
wr.write(remArrayServer.array); ELSE RAISE Wr.Failure(NIL); END; ELSE RAISE Wr.Failure(NIL); END; END WriteValArray;

PROCEDURE ReadValArray(self: ValArraySpecial; rd: Pickle.Reader; id: Pickle.RefID): REFANY RAISES {Pickle.Error, Rd.EndOfFile, Rd.Failure, Thread.Alerted} = VAR res: ValArray; BEGIN res := NEW(ValArray, remote := NEW(RemArrayServer, array := NIL)); rd.noteRef(res, id); NARROW(res.remote, RemArrayServer).array := rd.read(); RETURN res; END ReadValArray;


interface OpSys is in: