Copyright (C) 1994, Digital Equipment Corp. MODULE; IMPORT Text, Fmt, SynWr, SynLocation, ObTree, AtomList, Atom, ObEval, NetObj, Pickle, Rd, Wr, Thread, OSError, TextRefTbl, Refany, FileRd, FileWr, OpSys; ObValue
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;