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-- 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.ThisMachine (): TEXT = BEGIN TRY RETURN OpSys.GetHostName (); EXCEPT | OpSys.Error => RETURN "<unknown>"; END; END ThisMachine; PROCEDURESetup () = 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; PROCEDURERaiseError (msg: TEXT; location: SynLocation.T) RAISES {Error} = BEGIN RAISE Error(NEW(ErrorPacket, msg:=msg, location:=location)); END RaiseError; PROCEDURERaiseServerError (msg: TEXT) RAISES {ServerError} = BEGIN RAISE ServerError(msg); END RaiseServerError; PROCEDURESameException (exc1, exc2: ValException): BOOLEAN = BEGIN RETURN Text.Equal(exc1.name, exc2.name); END SameException; PROCEDURERaiseException (exception: ValException; msg: TEXT; loc: SynLocation.T) RAISES {Exception} = BEGIN RAISE Exception( NEW(ExceptionPacket, msg:=msg, location:=loc, exception:=exception, data:=NIL)); END RaiseException; PROCEDURERaiseNetException (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; PROCEDUREErrorMsg (swr: SynWr.T; packet: ErrorPacket) = BEGIN Msg(swr, "Execution error ", packet.msg, packet.location); END ErrorMsg; PROCEDUREExceptionMsg (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; PROCEDUREMsg (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; PROCEDUREBadOp (pkg, op: TEXT; location: SynLocation.T) RAISES {Error} = BEGIN RaiseError("Unknown operation: " & pkg & "_" & op, location); END BadOp; PROCEDUREBadArgType (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; PROCEDUREBadArgVal (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; PROCEDURENewEnv (name: ObTree.IdeName; env: Env): Env = BEGIN RETURN NEW(LocalEnv, name:=name, val:=NIL, rest:=env); END NewEnv; PROCEDUREExtendEnv (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; PROCEDUREPrintWhat (self: ValAnything): TEXT = BEGIN RETURN self.what; END PrintWhat; PROCEDUREIsSelfOther (self, other: ValAnything): BOOLEAN = BEGIN RETURN self=other; END IsSelfOther; PROCEDUREIs (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; PROCEDURENewText (text: TEXT): Val = BEGIN IF text=NIL THEN text:="" END; RETURN NEW(ValText, text:=text); END NewText; PROCEDURENewVar (val: Val): ValVar = BEGIN RETURN NEW(ValVar, remote := NEW(RemVarServer, val:=val)); END NewVar; PROCEDUREVarGet (self: RemVarServer): Val RAISES {} = BEGIN RETURN self.val; END VarGet; PROCEDUREVarSet (self: RemVarServer; val: Val) RAISES {} = BEGIN self.val := val; END VarSet; PROCEDURENewArray (READONLY vals: Vals): ValArray = VAR newVals: REF Vals; BEGIN newVals := NEW(REF Vals, NUMBER(vals)); newVals^ := vals; RETURN NewArrayFromVals(newVals); END NewArray; PROCEDURENewArrayFromVals (vals: REF Vals): ValArray = BEGIN RETURN NEW(ValArray, remote := NEW(RemArrayServer, array:=vals)); END NewArrayFromVals; PROCEDUREArraySize (arr: RemArrayServer): INTEGER RAISES {} = BEGIN RETURN NUMBER(arr.array^); END ArraySize; PROCEDUREArrayGet (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; PROCEDUREArraySet (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; PROCEDUREArraySub (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; PROCEDUREArrayUpd (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; PROCEDUREArrayObtain (self: RemArrayServer): REF Vals RAISES {} = BEGIN RETURN self.array; END ArrayObtain; PROCEDUREArrayCat (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; PROCEDURENewObject (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; PROCEDURENewObjectFromFields (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; PROCEDUREObjWho (self: RemObjServer; VAR(*out*) protected, serialized: BOOLEAN): TEXT RAISES {} = BEGIN protected := self.protected; serialized := self.sync # NIL; RETURN self.who; END ObjWho; PROCEDUREObjClone1 (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; PROCEDUREObjClone (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; PROCEDUREBadArgsNoMsg (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; PROCEDUREObjSelect (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; PROCEDUREObjHas (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; PROCEDUREObjInvoke (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; PROCEDUREObjUpdate (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; PROCEDUREObjRedirect (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; PROCEDUREObjObtain (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; PROCEDURENewAlias (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; PROCEDUREEngineWho (self: RemEngineServer): TEXT RAISES {} = BEGIN RETURN self.who; END EngineWho; PROCEDUREEngineEval (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; PROCEDURENewFileSystem (readOnly: BOOLEAN): ValFileSystem = BEGIN RETURN NEW(ValFileSystem, picklable := FALSE, what:="<FileSystem at " & machineAddress & ">", remote := NEW(RemFileSystemServer, readOnly:=readOnly)); END NewFileSystem; PROCEDUREFileSystemIs (self: ValFileSystem; other: ValAnything): BOOLEAN = BEGIN TYPECASE other OF | ValFileSystem(oth) => RETURN self.remote = oth.remote; ELSE RETURN FALSE; END; END FileSystemIs; PROCEDUREFileSystemOpenRead (<*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; PROCEDUREFileSystemOpenWrite (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; PROCEDUREFileSystemOpenAppend (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; PROCEDURENewProcessor (): ValProcessor = BEGIN RETURN NEW(ValProcessor, picklable := FALSE, what:="<Processor at " & machineAddress & ">"); END NewProcessor; PROCEDURERegisterSysCall (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; PROCEDUREFetchSysCall (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; PROCEDURENewTbl (): Tbl = BEGIN RETURN NEW(Tbl, a:=NEW(REF TblArr, 256), top:=0); END NewTbl; PROCEDURETblGet (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; PROCEDURETblPut (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; PROCEDURECopyVal (val: Val; tbl: Tbl; loc: SynLocation.T) : Val RAISES {Error, NetObj.Error} = BEGIN RETURN Copy(val, tbl, loc, CopyStyle.ValToVal); END CopyVal; PROCEDURECopyValToLocal (val: Val; tbl: Tbl; loc: SynLocation.T) : Val RAISES {Error, NetObj.Error} = BEGIN RETURN Copy(val, tbl, loc, CopyStyle.ValToLocal); END CopyValToLocal; PROCEDURECopyLocalToVal (val: Val; tbl: Tbl; loc: SynLocation.T) : Val RAISES {Error, NetObj.Error} = BEGIN RETURN Copy(val, tbl, loc, CopyStyle.LocalToVal); END CopyLocalToVal; PROCEDURECopy (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; PROCEDURECopyId (self: ValAnything; <*UNUSED*>tbl: Tbl; <*UNUSED*>loc: SynLocation.T) : ValAnything = BEGIN RETURN self; END CopyId; PROCEDURECopyError (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; PROCEDUREWriteInhibitTransmission (self: InhibitSpecial; <*UNUSED*>ref: REFANY; <*UNUSED*>wr: Pickle.Writer) RAISES {Pickle.Error, Wr.Failure, Thread.Alerted} = BEGIN RAISE Pickle.Error(self.reason); END WriteInhibitTransmission; PROCEDUREReadInhibitTransmission (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; PROCEDUREInhibitTransmission (tc: INTEGER; reason: TEXT) = BEGIN Pickle.RegisterSpecial(NEW(InhibitSpecial, sc:=tc, reason:=reason)); END InhibitTransmission; BEGIN END ObValue.
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;