MODULE; IMPORT SOxCodeUtils, SOxCoder, Formatter, ImportList, SOxCodeGenError, Type, SOxCodeFiles, Wr, CodeForType, Atom, AtomList, AtomListFuncs, Text, Value, Fmt, StubCode; REVEAL T = SOxCoder.T BRANDED OBJECT initializers:= ""; OVERRIDES InitImports := initImports; Import := import; Head := head; Decls := decls; Main := main; Bottom := bottom; END; <* FATAL Wr.Failure*> PROCEDURE SOxModuleSOCode PutLine (fmtWr: Formatter.T; text: TEXT) = BEGIN Formatter.PutText(fmtWr, text); Formatter.NewLine(fmtWr, freshLine := FALSE); END PutLine; PROCEDUREEndLine (fmtWr: Formatter.T; text: TEXT) = BEGIN Formatter.PutText(fmtWr, text); Formatter.End(fmtWr); Formatter.NewLine(fmtWr, freshLine := FALSE); END EndLine; VAR extraImports := ARRAY [1 .. 16] OF Atom.T{ Atom.FromText("SharedObj"), Atom.FromText("SharedObjRep"), Atom.FromText("SharedObjStubLib"), Atom.FromText("WeakRef"), Atom.FromText("EventStubLib"), Atom.FromText("EventProtocol"), Atom.FromText("Rd"), Atom.FromText("Wr"), Atom.FromText("SharedObjError"), Atom.FromText("ThreadF"), Atom.FromText("Thread"), Atom.FromText("Event"), Atom.FromText("Pickle2 AS Pickle"), Atom.FromText("EmbProxiedObj"), Atom.FromText("PickleStubs"), Atom.FromText("ObjectSpace")
Atom.FromText(
Time
), Atom.FromText(Fmt
), Atom.FromText(IO
)
}; PROCEDUREinitImports (<*UNUSED*> self : T; basename: TEXT; imports : ImportList.T) = VAR imp := ARRAY [1 .. 1] OF Atom.T{Atom.FromText(SOxCodeUtils.FileName( basename, SOxCodeFiles.T.CB_I3))}; BEGIN CodeForType.AugmentImportList(imports, extraImports); CodeForType.AugmentImportList(imports, imp); END initImports; PROCEDUREimport (<*UNUSED*> self : T; type : Type.Object; methods : ImportList.MethodList; umethods: AtomList.T; imports : ImportList.T ) = BEGIN (* CodeForType.ImportLst(type, imports, methods, umethods); *) CodeForType.ImportSOLst(type, imports, methods, umethods); END import; PROCEDUREhead (self : T; wr : Formatter.T; fname : TEXT; basename: TEXT; imports : ImportList.T ) = BEGIN WITH Put = Formatter.PutText, Tab = Formatter.Begin, Nl = Formatter.NewLine DO SOxCodeUtils.HeaderComment(wr, fname); self.basename := basename; self.fbasename := SOxCodeUtils.FileName(basename, SOxCodeFiles.T.SO_M3); Put(wr, "MODULE " & self.fbasename & " EXPORTS "); Tab(wr, 0); PutLine(wr, SOxCodeUtils.FileName(basename, SOxCodeFiles.T.PKL_I3) & ", "); EndLine(wr, self.basename & ", " & SOxCodeUtils.FileName( basename, SOxCodeFiles.T.PRX_I3) & ";"); CodeForType.ProduceImports(wr, imports); Nl(wr, freshLine := FALSE); PutLine(wr, "CONST SharedObj_Protocol: EventProtocol.StubProtocol = 1;"); PutLine(wr, "EXCEPTION DuplicateSpecial;"); Nl(wr, freshLine := TRUE); END; END head; PROCEDUREdecls ( self : T; wr : Formatter.T; typeID : Type.Qid; stypeID : Type.Qid; <*UNUSED*> implName: TEXT; methods : ImportList.MethodList; umethods: AtomList.T ) = VAR typTxt : TEXT; identfTxt, identfsTxt: TEXT; meth : Atom.T; firstMeth : BOOLEAN; BEGIN WITH Put = Formatter.PutText, Nl = Formatter.NewLine, Tab = Formatter.Begin, Br = Formatter.Break, Grp = Formatter.Group, EndTab = Formatter.End DO typTxt := CodeForType.QidToText(typeID); identfTxt := CodeForType.QidToIdentf(typeID); identfsTxt := CodeForType.QidToIdentf(stypeID); Put(wr, "TYPE " & identfTxt & "_SOMethods = {"); Tab(wr, 0); firstMeth := TRUE; FOR i := 0 TO LAST(methods^) DO meth := methods[i].name; IF AtomList.Member(umethods, meth) THEN IF firstMeth THEN firstMeth := FALSE ELSE Put(wr, ", "); Br(wr); END; Put(wr, Atom.ToText(meth)); END; END; EndLine(wr, "};"); Nl(wr, freshLine := FALSE); Tab(wr, 2); Put(wr, "REVEAL"); Nl(wr, freshLine := FALSE); PutLine(wr, identfTxt & " = " & identfsTxt & " BRANDED \"Shared" & " " & self.basename & "." & identfTxt & " v1.0\" OBJECT"); Tab(wr, 2); PutLine(wr, "OVERRIDES"); IF SOxCodeUtils.genProxyCode THEN PutLine(wr, "makeProxy := MakeProxy_" & identfTxt & ";"); END; PutLine(wr, "applyUpdate := ApplyUpdate_" & identfTxt & ";"); FOR i := 0 TO LAST(methods^) DO meth := methods[i].name; Nl(wr, freshLine := FALSE); Grp(wr); Put(wr, Atom.ToText(meth) & " := "); Put(wr, "Shared_" & Atom.ToText(meth) & "_" & identfTxt & ";"); EndTab(wr); END; EndTab(wr); Nl(wr, freshLine := FALSE); PutLine(wr, "END;"); EndTab(wr); Nl(wr, freshLine := FALSE); END; END decls; PROCEDUREmain ( self : T; wr : Formatter.T; typeID : Type.Qid; type : Type.Object; stypeID : Type.Qid; <*UNUSED*> implName: TEXT; methods : ImportList.MethodList; umethods: AtomList.T ) RAISES {SOxCodeGenError.E} = VAR methTxt, typTxt : TEXT; identfTxt, identfsTxt: TEXT; meth : Atom.T; exceptions : AtomList.T := NIL; SOexports := AtomList.List2(Atom.FromText(self.basename), Atom.FromText(SOxCodeUtils.FileName( self.basename, SOxCodeFiles.T.PRX_I3))); BEGIN WITH Put = Formatter.PutText, Br = Formatter.Break, Nl = Formatter.NewLine, Tab = Formatter.Begin, EndTab = Formatter.End DO typTxt := CodeForType.QidToText(typeID); identfTxt := CodeForType.QidToIdentf(typeID); identfsTxt := CodeForType.QidToIdentf(stypeID); FOR i := 0 TO LAST(methods^) DO IF AtomList.Member(umethods, methods[i].name) THEN CodeForType.AugmentExceptionList(exceptions, methods[i].sig.raises, SOexports); END; END; IF SOxCodeUtils.genProxyCode THEN Tab(wr, 2); PutLine(wr, "PROCEDURE MakeProxy_" & identfTxt & " (self: " & identfTxt & ") ="); Tab(wr, 2); PutLine(wr, "BEGIN"); Tab(wr, 2); PutLine(wr, "IF MkProxy" & identfTxt & " # NIL THEN"); EndLine(wr, "MkProxy" & identfTxt & "(self);"); EndLine(wr, "END;"); EndLine(wr, "END MakeProxy_" & identfTxt & ";"); END; Nl(wr, freshLine := FALSE); Tab(wr, 2); Put(wr, "PROCEDURE ApplyUpdate_" & identfTxt & " ("); Tab(wr, 0); Put(wr, "self: " & identfTxt & "; "); Br(wr); Put(wr, "ev: Event.T; "); Br(wr); Put(wr, "h: EventStubLib.Handle) "); EndTab(wr); Br(wr); Put(wr, "RAISES {"); Tab(wr, 0); Put(wr, "SharedObj.Error, "); EVAL AtomListFuncs.DeleteD(exceptions, Atom.FromText("SharedObj.Error")); Br(wr); IF AtomListFuncs.DeleteD(exceptions, Atom.FromText("SharedObj.Fatal")) # NIL THEN Put(wr, "SharedObj.Fatal, "); Br(wr); END; Put(wr, "Event.Error, "); Br(wr); Put(wr, "Rd.Failure, "); Br(wr); EndLine(wr, "Thread.Alerted} ="); Tab(wr, 2); PutLine(wr, "BEGIN"); Tab(wr, 2); PutLine(wr, "IF ev.prot # SharedObj_Protocol THEN"); EndLine(wr, "EventStubLib.RaiseUnmarshalFailure();"); PutLine(wr, "END;"); Tab(wr, 2); PutLine(wr, "WITH meth = SharedObjStubLib.InInt32(h) DO"); Tab(wr, 2); IF exceptions # NIL THEN PutLine(wr, "TRY"); Tab(wr, 2); END; PutLine(wr, "TRY"); PutLine(wr, "SharedObjStubLib.AcquireWriteLock(self);"); PutLine(wr, "self.updating := ThreadF.MyId();"); PutLine(wr, "CASE meth OF"); FOR i := 0 TO LAST(methods^) DO meth := methods[i].name; methTxt := Atom.ToText(meth); IF AtomList.Member(umethods, meth) THEN Put(wr, "| "); Tab(wr, 0); Put(wr, "ORD(" & identfTxt & "_SOMethods." & methTxt & ") => "); Br(wr); EndLine(wr, "Stub_" & methTxt & "_" & identfTxt & "(self, h);"); END; END; Tab(wr, 2); PutLine(wr, "ELSE"); EndLine(wr, "EventStubLib.RaiseUnmarshalFailure();"); EndLine(wr, "END;"); Tab(wr, 2); PutLine(wr, "FINALLY"); PutLine(wr, "self.updating := -1;"); EndLine(wr, "SharedObjStubLib.ReleaseWriteLock(self);"); EndLine(wr, "END;"); IF exceptions # NIL THEN Tab(wr, 2); Put(wr, "EXCEPT "); Br(wr); WHILE exceptions # NIL DO Put(wr, Atom.ToText(exceptions.head)); IF exceptions.tail # NIL THEN Put(wr, ", "); END; Br(wr); exceptions := exceptions.tail; END; Put(wr, "=> "); Br(wr); EndLine(wr, "(* ignore these exceptions quietly *)"); EndLine(wr, "END;"); END; EndLine(wr, "END;"); EndLine(wr, "END ApplyUpdate_" & identfTxt & ";"); Nl(wr, freshLine := FALSE); Surrogates(self, wr, type, identfTxt, identfsTxt, methods, umethods); Stubs(self, wr, type, identfTxt, identfsTxt, methods, umethods); Callbacks(self, wr, type, identfTxt, identfsTxt, methods, umethods); Picklers(self, wr, type, identfTxt, identfsTxt); END; END main; PROCEDUREbottom (self: T; wr: Formatter.T; <*UNUSED*> fname: TEXT) = BEGIN WITH Put = Formatter.PutText, Nl = Formatter.NewLine DO Nl(wr, freshLine := FALSE); PutLine(wr, "BEGIN"); Put(wr, self.initializers); PutLine(wr, "END " & self.fbasename & "."); END; END bottom; TYPE Direction = {In, Out}; PROCEDUREPrintStubArgs (wr : Formatter.T; sig: Type.Signature; dir: Direction ) = BEGIN FOR j := 0 TO LAST(sig.formals^) DO Formatter.PutText(wr, ", "); Formatter.Break(wr); Formatter.PutText(wr, Atom.ToText(sig.formals[j].name) & "_arg"); IF dir = Direction.In THEN TYPECASE sig.formals[j].type OF | Type.OpenArray => Formatter.PutText(wr, "^"); ELSE END; END; END; END PrintStubArgs; PROCEDURESurrogates (self: T; wr : Formatter.T; t : Type.Object; identfTxt, identfsTxt: TEXT; methods : ImportList.MethodList; umethods: AtomList.T ) RAISES {SOxCodeGenError.E} = VAR procedureName: TEXT; uMeth : BOOLEAN; methTxt : TEXT; meth : Atom.T; SOexports := AtomList.List2(Atom.FromText(self.basename), Atom.FromText(SOxCodeUtils.FileName( self.basename, SOxCodeFiles.T.PRX_I3))); BEGIN WITH Put = Formatter.PutText, Nl = Formatter.NewLine, Tab = Formatter.Begin, EndTab = Formatter.End DO FOR i := 0 TO LAST(methods^) DO meth := methods[i].name; methTxt := Atom.ToText(meth); uMeth := AtomList.Member(umethods, meth); procedureName := "Shared_" & Atom.ToText(methods[i].name) & "_" & identfTxt; Tab(wr, 2); CodeForType.ProcHeader(wr, t, procedureName, methods[i].sig, suffix := "_arg", exports := SOexports); PutLine(wr, " = "); IF uMeth THEN Tab(wr, 4); PutLine(wr, "VAR out: SharedObjStubLib.Handle;"); PutLine(wr, "id := ThreadF.MyId();"); EndLine(wr, "dataPresent: BOOLEAN; <* NOWARN *>"); (* PutLine(wr, "stubProt: StubLib.StubProtocol;"); *)
IF methods[i].sig.result # NIL THEN PutLine(wr,
res:
& CodeForType.ToText(methods[i].sig.result) &;
); END;
IF StubUtils.perfMon THEN
PutLine(wr, wridx, rdidx: INTEGER;
& PerfComment);
END;
END; Tab(wr, 2); PutLine(wr, "BEGIN"); IF Text.Equal("init", Atom.ToText(methods[i].name)) THEN PutLine( wr, "(**************************************************)"); PutLine( wr, "(* This get's done once. After that, it's a noop. *)"); PutLine( wr, "(**************************************************)"); PutLine(wr, "self := NARROW(SharedObj.Init(self), " & identfTxt & ");"); PutLine(wr, "self.makeProxy();"); PutLine( wr, "(**************************************************)"); END; PutLine(wr, "IF NOT self.ok THEN " & "SharedObjError.RaiseDeadObject() END;"); IF uMeth THEN Tab(wr, 2); PutLine(wr, "TRY"); PutLine(wr, "SharedObjStubLib.AcquireReadLock(self);"); Tab(wr, 2); PutLine(wr, "IF self.updating = id THEN "); PutLine(wr, "(* do a simple, non-update call to the method *)"); IF methods[i].sig.result # NIL THEN Put(wr, "RETURN "); END; Put(wr, identfsTxt & "." & Atom.ToText(methods[i].name) & "("); Tab(wr, 0); Put(wr, "self"); PrintStubArgs(wr, methods[i].sig, Direction.Out); EndTab(wr); IF methods[i].sig.result # NIL THEN EndLine(wr, ");"); ELSE PutLine(wr, ");"); EndLine(wr, "RETURN;"); END; EndLine(wr, "END;"); Tab(wr, 2); PutLine(wr, "FINALLY"); EndLine(wr, "SharedObjStubLib.ReleaseReadLock(self);"); PutLine(wr, "END;"); (* "SharedObjError.RaiseRecursiveUpdate(); END;"); *) Tab(wr, 2); PutLine(wr, "TRY");
IF StubUtils.perfMon THEN PutLine(wr,
IF NetObjPerf.enabled THEN
& PerfComment); PutLine(wr,NetObjPerf.StartCall(PerfUtil.ThreadId(),
& Fmt.Int(NUMBER(methods[i].sig.formals^)) &);
); PutLine(wr,END;
); END;
PutLine(wr, "out := SharedObjStubLib.StartCall(self);"); Tab(wr, 2); PutLine(wr, "IF SharedObjStubLib.MarshalArgs(out) THEN"); PutLine(wr, "SharedObjStubLib.OutInt32(out, ORD(" & identfTxt & "_SOMethods." & Atom.ToText(methods[i].name) & "));");
IF StubUtils.perfMon THEN PutLine(wr,
wridx := Wr.Index(c.wr);
& PerfComment); END;
FOR j := 0 TO LAST(methods[i].sig.formals^) DO WITH f = methods[i].sig.formals[j] DO MarshalTypedVal(wr, Atom.ToText(f.name) & "_arg", "SharedObjStubLib", f.type, Direction.Out, calling := TRUE, maySuppress := TRUE); END; END;
IF StubUtils.perfMon THEN PutLine(wr,
wridx := Wr.Index(c.wr) - wridx;
& PerfComment); END;
EndTab(wr); PutLine(wr, "END;"); PutLine(wr, "SharedObjStubLib.SequenceCall(out, SharedObj_Protocol);"); Tab(wr, 2); PutLine(wr, "TRY"); PutLine(wr, "SharedObjStubLib.AcquireWriteLock(self);"); PutLine(wr, "self.updating := id;"); Put(wr, "Callback_pre_" & Atom.ToText(methods[i].name) & "_" & identfTxt & "("); Tab(wr, 0); Put(wr, "self"); PrintStubArgs(wr, methods[i].sig, Direction.Out); EndTab(wr); PutLine(wr, ");"); IF methods[i].sig.result # NIL THEN Tab(wr, 2); Put(wr, "WITH res = "); END; Put(wr, identfsTxt & "." & Atom.ToText(methods[i].name) & "("); Tab(wr, 0); Put(wr, "self"); PrintStubArgs(wr, methods[i].sig, Direction.Out); EndTab(wr); IF methods[i].sig.result # NIL THEN PutLine(wr, ") DO"); ELSE PutLine(wr, ");"); END; Put(wr, "Callback_post_" & Atom.ToText(methods[i].name) & "_" & identfTxt & "("); Tab(wr, 0); Put(wr, "self"); PrintStubArgs(wr, methods[i].sig, Direction.Out); EndTab(wr); IF methods[i].sig.result # NIL THEN PutLine(wr, ");"); EndLine(wr, "RETURN res;"); EndLine(wr, "END;"); ELSE EndLine(wr, ");"); END; Tab(wr, 2); PutLine(wr, "FINALLY"); PutLine(wr, "self.updating := -1;"); PutLine(wr, "SharedObjStubLib.ReleaseWriteLock(self);"); EndLine(wr, "SharedObjStubLib.EndCall(out);"); EndLine(wr, "END;"); PutLine(wr, "EXCEPT"); Put(wr, "| Wr.Failure (ec) => SharedObjError.RaiseCommFailure(ec)"); IF methods[i].sig.result # NIL THEN PutLine(wr, "; <*ASSERT FALSE*>"); ELSE PutLine(wr, ";"); END; Put(wr, "| Thread.Alerted => SharedObjError.RaiseAlerted()"); IF methods[i].sig.result # NIL THEN PutLine(wr, "; <*ASSERT FALSE*>"); ELSE PutLine(wr, ";"); END; EndLine(wr, "END;");
IF StubUtils.perfMon THEN
PutLine(wr, rdidx := Rd.Index(c.rd);
& PerfComment);
END;
ELSE Tab(wr, 2); PutLine(wr, "TRY"); PutLine(wr, "SharedObjStubLib.AcquireReadLock(self);"); IF methods[i].sig.result # NIL THEN Put(wr, "RETURN "); END; Put(wr, identfsTxt & "." & Atom.ToText(methods[i].name) & "("); Tab(wr, 0); Put(wr, "self"); PrintStubArgs(wr, methods[i].sig, Direction.Out); EndTab(wr); EndLine(wr, ");"); Tab(wr, 2); PutLine(wr, "FINALLY"); EndLine(wr, "SharedObjStubLib.ReleaseReadLock(self);"); EndLine(wr, "END;"); END; EndLine(wr, "END " & procedureName & ";"); Nl(wr, freshLine := FALSE); END; END; END Surrogates; PROCEDUREStubs (self: T; wr : Formatter.T; t: Type.Object; identfTxt, identfsTxt: TEXT; methods : ImportList.MethodList; umethods: AtomList.T ) RAISES {SOxCodeGenError.E} = VAR varType: Type.T; SOexports := AtomList.List2(Atom.FromText(self.basename), Atom.FromText(SOxCodeUtils.FileName( self.basename, SOxCodeFiles.T.PRX_I3))); BEGIN FOR i := 0 TO LAST(methods^) DO WITH Put = Formatter.PutText, Nl = Formatter.NewLine, Tab = Formatter.Begin, EndTab = Formatter.End,
Br = Formatter.Break,
sig = methods[i].sig, stubSig = StubCode.SigForStub(sig), meth = methods[i].name, methTxt = Atom.ToText(meth), procedureName = "Stub_" & methTxt & "_" & identfTxt DO IF AtomList.Member(umethods, meth) THEN Tab(wr, 2); CodeForType.ProcHeader(wr, t, procedureName, stubSig, StubCode.PragmasForStub(), exports := SOexports); PutLine(wr, " = "); IF NUMBER(sig.formals^) > 0 THEN Tab(wr, 6); Put(wr, " VAR "); FOR j := 0 TO LAST(sig.formals^) DO WITH f = sig.formals[j] DO TYPECASE f.type OF | Type.OpenArray (oa) => varType := oa.refArray ELSE varType := f.type; END; WITH txt = Atom.ToText(f.name)& "_arg: " & CodeForType.ToText(varType, exports := SOexports) & ";" DO PutLine(wr, txt); END; END; END; EndLine(wr, "dataPresent: BOOLEAN <* NOWARN *>;"); END; Tab(wr, 2); PutLine(wr, "BEGIN"); FOR j := 0 TO LAST(sig.formals^) DO WITH f = sig.formals[j] DO MarshalTypedVal(wr, Atom.ToText(f.name) & "_arg", "SharedObjStubLib", f.type, Direction.In, calling := TRUE, maySuppress := TRUE); END; END; Put(wr, "Callback_pre_" & methTxt & "_" & identfTxt & "("); Tab(wr, 0); Put(wr, "self"); PrintStubArgs(wr, sig, Direction.In); EndTab(wr); PutLine(wr, ");"); IF sig.result # NIL THEN Put(wr, "EVAL "); END; Put(wr, identfsTxt & "." & methTxt & "("); Tab(wr, 0); Put(wr, "self"); PrintStubArgs(wr, sig, Direction.In); EndTab(wr); PutLine(wr, ");"); Put(wr, "Callback_post_" & methTxt & "_" & identfTxt & "("); Tab(wr, 0); Put(wr, "self"); PrintStubArgs(wr, sig, Direction.In); EndTab(wr); EndLine(wr, ");"); EndLine(wr, "END " & procedureName & ";"); Nl(wr, freshLine := FALSE); END; END; END; END Stubs; VAR cbName := ARRAY [0..1] OF Text.T{ "pre", "post" }; PROCEDURECallbacks (self: T; wr : Formatter.T; <*UNUSED*>t: Type.Object; identfTxt: TEXT; <*UNUSED*>identfsTxt: TEXT; methods : ImportList.MethodList; umethods: AtomList.T ) = VAR SOexports := AtomList.List2(Atom.FromText(self.basename), Atom.FromText(SOxCodeUtils.FileName( self.basename, SOxCodeFiles.T.PRX_I3))); procedureName: TEXT; BEGIN FOR i := 0 TO LAST(methods^) DO WITH Put = Formatter.PutText, Nl = Formatter.NewLine, EndTab = Formatter.End, Tab = Formatter.Begin, sig = methods[i].sig, meth = methods[i].name, methTxt = Atom.ToText(meth) DO IF AtomList.Member(umethods, meth) THEN FOR j := FIRST(cbName) TO LAST(cbName) DO procedureName := "Callback_" & cbName[j] & "_" & methTxt & "_" & identfTxt; Tab(wr, 2); Put(wr, "PROCEDURE " & procedureName & "("); Tab(wr,0); Put(wr, "self: " & identfTxt); CodeForType.PrintSig(wr, sig, NIL, suffix := "_arg", exports := SOexports); EndLine(wr, ") =");
CodeForType.ProcHeader(wr, t, procedureName, sig, suffix :=
_arg
, exports := SOexports);
PutLine(wr, "VAR cbs := self.callbacks;"); Tab(wr, 2); PutLine(wr, "BEGIN"); Tab(wr, 2); PutLine(wr, "WHILE cbs # NIL DO"); Tab(wr, 2); PutLine(wr, "IF cbs.head.ready THEN"); Tab(wr, 2); PutLine(wr, "WITH ref = WeakRef.ToRef(cbs.head.weakRef) DO"); Tab(wr, 2); PutLine(wr, "IF ref # NIL THEN"); Tab(wr, 2); PutLine(wr, "WITH cb = NARROW(ref, " & SOxCodeUtils.FileName(self.basename, SOxCodeFiles.T.CB_I3) & "." & identfTxt & ") DO"); Tab(wr, 2); Put(wr, "IF NOT cb." & cbName[j] & "_" & methTxt & "("); Tab(wr, 0); Put(wr, "self"); PrintStubArgs(wr, sig, Direction.Out); EndTab(wr); PutLine(wr, ") THEN"); EndLine(wr, "cb." & cbName[j] & "_anyChange(self);"); EndLine(wr, "END;"); EndLine(wr, "END;"); EndLine(wr, "END;"); EndLine(wr, "END;"); PutLine(wr, "END;"); EndLine(wr, "cbs := cbs.tail;"); EndLine(wr, "END;"); EndLine(wr, "END " & procedureName & ";"); Nl(wr, freshLine := FALSE); END; END; END; END; END Callbacks; PROCEDUREPicklers (self: T; wr : Formatter.T; t: Type.Object; identfTxt, identfsTxt: TEXT) RAISES {SOxCodeGenError.E} = VAR procedureName: Text.T; BEGIN WITH Put = Formatter.PutText, Nl = Formatter.NewLine, EndTab = Formatter.End, Br = Formatter.Break, Tab = Formatter.Begin, nodata = (NUMBER(t.fields^) = 0) DO PutLine(wr, "(* The pickling routine for this shared object." & " We will register a"); PutLine(wr, " pickler for " & self.basename & "." & identfsTxt & ", and then handle both " & identfsTxt & " and " & identfTxt & "."); PutLine(wr, " Pickling subtypes of " & identfTxt & " is illegal. *)"); Tab(wr, 2); PutLine(wr, "REVEAL"); Put(wr, identfTxt & "Special = "); Tab(wr, 0); PutLine(wr, "SharedObj.Special BRANDED \"" & self.basename & "." & identfTxt & "Special\" OBJECT"); Tab(wr, 2); PutLine(wr, "OVERRIDES"); PutLine(wr, "write := DefaultSpWrite_" & identfTxt & ";"); EndLine(wr, "read := DefaultSpRead_" & identfTxt & ";"); EndLine(wr, "END;"); EndLine(wr, ""); Tab(wr, 2); PutLine(wr, "TYPE"); Put(wr, identfTxt & "_Special = "); Tab(wr, 0); Tab(wr, 2); PutLine(wr, "Pickle.Special OBJECT"); PutLine(wr, "mu: MUTEX;"); PutLine(wr, "sp: " & identfTxt & "Special;"); EndLine(wr, "registered: BOOLEAN := FALSE;"); Tab(wr, 2); PutLine(wr, "OVERRIDES"); PutLine(wr, "write := Write_" & identfTxt & ";"); EndLine(wr, "read := Read_" & identfTxt & ";"); EndLine(wr, "END;"); EndLine(wr, ""); Tab(wr, 2); procedureName := "DefaultSpWrite_" & identfTxt; Put(wr, "PROCEDURE " & procedureName & " ("); Tab(wr, 0); Put(wr, "<*UNUSED*>self: " & identfTxt & "Special; "); Br(wr); IF nodata THEN Put(wr, "<*UNUSED*>"); END; Put(wr, "shobj: SharedObj.T; "); Br(wr); IF nodata THEN Put(wr, "<*UNUSED*>"); END; PutLine(wr, "out: Pickle.Writer)"); EndTab(wr); IF nodata THEN PutLine(wr, " ="); ELSE PutLine(wr, "RAISES {Pickle.Error, Wr.Failure, Thread.Alerted} ="); END; Tab(wr, 2); IF NOT nodata THEN PutLine(wr, "VAR"); EndLine(wr, "obj := NARROW(shobj, " & identfsTxt & ");"); Tab(wr, 2); END; PutLine(wr, "BEGIN"); FOR j := 0 TO LAST(t.fields^) DO WITH f = t.fields[j] DO MarshalTypedVal(wr, "obj." & Atom.ToText(f.name), "PickleStubs", f.type, Direction.Out, calling := TRUE, maySuppress := TRUE); END; END; EndTab(wr); Nl(wr, freshLine := FALSE); EndLine(wr, "END " & procedureName & ";"); Nl(wr, freshLine := FALSE); Tab(wr, 2); procedureName := "Write_" & identfTxt; Put(wr, "PROCEDURE " & procedureName & " ("); Tab(wr, 0); Put(wr, "<*UNUSED*>ts: " & identfTxt & "_Special; "); Br(wr); Put(wr, "ref: REFANY; "); Br(wr); PutLine(wr, "out: Pickle.Writer)"); EndTab(wr); PutLine(wr, "RAISES {Pickle.Error, Wr.Failure, Thread.Alerted} ="); Tab(wr, 2); PutLine(wr, "VAR"); PutLine(wr, "obj: " & identfsTxt & ";"); PutLine(wr, "sp: " & identfTxt & "Special;"); EndLine(wr, "tc := TYPECODE(ref);"); Tab(wr, 2); PutLine(wr, "BEGIN");
PutLine(wr, IO.Put(\
Pickle.Special for &
self.basename &
. & identfsTxt &
\\n\);
);
Tab(wr, 2); PutLine(wr, "IF tc # TYPECODE(" & identfsTxt & ") AND tc # TYPECODE(" & identfTxt & ") THEN"); EndLine(wr, "RAISE Pickle.Error(\"Can't pickle subtypes of " & self.basename & "." & identfTxt & "\");"); PutLine(wr, "END;"); PutLine(wr, "obj := NARROW(ref, " & identfsTxt & ");"); PutLine(wr, "out.writeType(tc);");
PutLine(wr,
IO.Put(\
Pickle.Special.wr for& self.basename &
.& identfsTxt &
: writing shared obj\\n\);
);
PutLine(wr, "SharedObjStubLib.StartWritePickle(obj, out);"); Tab(wr,2); PutLine(wr, "LOCK sp" & identfTxt & ".mu DO"); EndLine(wr, "sp := sp" & identfTxt & ".sp;"); PutLine(wr, "END;"); PutLine(wr, "sp.write(obj, out);"); EndLine(wr, "SharedObjStubLib.EndWritePickle(obj, out);");
EndLine(wr,
IO.Put(\
Pickle.Special.wr for& self.basename &
.& identfsTxt &
: wrote shared obj\\n\);
);
EndLine(wr, "END " & procedureName & ";"); Nl(wr, freshLine := FALSE); Tab(wr, 2); procedureName := "DefaultSpRead_" & identfTxt; Put(wr, "PROCEDURE " & procedureName & " ("); Tab(wr, 0); Put(wr, "<*UNUSED*>self: " & identfTxt & "Special; "); Br(wr); IF nodata THEN Put(wr, "<*UNUSED*>"); END; Put(wr, "shobj: SharedObj.T; "); Br(wr); IF nodata THEN Put(wr, "<*UNUSED*>"); END; Put(wr, "in: Pickle.Reader) "); Br(wr); EndTab(wr); IF nodata THEN PutLine(wr, " ="); ELSE Put(wr, "RAISES {"); Br(wr); Tab(wr, 0); Put(wr, "Pickle.Error, "); Br(wr); Put(wr, "Rd.EndOfFile, "); Br(wr); Put(wr, "Rd.Failure, "); Br(wr); EndLine(wr, "Thread.Alerted} ="); END; Tab(wr, 2); IF NOT nodata THEN PutLine(wr, "VAR"); EndLine(wr, "obj := NARROW(shobj, " & identfsTxt & ");"); Tab(wr, 2); END; PutLine(wr, "BEGIN"); FOR j := 0 TO LAST(t.fields^) DO WITH f = t.fields[j] DO MarshalTypedVal(wr, "obj." & Atom.ToText(f.name), "PickleStubs", f.type, Direction.In, calling := TRUE, maySuppress := TRUE); END; END; EndTab(wr); Nl(wr, freshLine := FALSE); EndLine(wr, "END " & procedureName & ";"); Nl(wr, freshLine := FALSE); Tab(wr, 2); procedureName := "Read_" & identfTxt; Put(wr, "PROCEDURE " & procedureName & " ("); Tab(wr, 0); Put(wr, "<*UNUSED*>ts: " & identfTxt & "_Special; in: Pickle.Reader; "); Br(wr); Put(wr, "id: Pickle.RefID):"); Br(wr); EndTab(wr); Put(wr, "REFANY RAISES {"); Br(wr); Tab(wr, 0); Put(wr, "Pickle.Error, "); Br(wr); Put(wr, "Rd.EndOfFile, "); Br(wr); Put(wr, "Rd.Failure, "); Br(wr); EndLine(wr, "Thread.Alerted} ="); Tab(wr, 2); PutLine(wr, "VAR"); PutLine(wr, "space: ObjectSpace.T;"); PutLine(wr, "obj: " & identfsTxt & ";"); PutLine(wr, "sp: " & identfTxt & "Special;"); PutLine(wr, "proxy: EmbProxiedObj.Proxy;"); EndLine(wr, "tc := in.readType();"); Tab(wr, 2); PutLine(wr, "BEGIN"); Tab(wr, 2); PutLine(wr, "IF tc = TYPECODE(" & identfTxt & ") THEN");
PutLine(wr,
IO.Put(\
Pickle.Special.rd for& self.basename &
.& identfsTxt &
: shared obj\\n\);
);
EndLine(wr, "obj := NEW(" & identfTxt & ");"); Tab(wr, 2); PutLine(wr, "ELSIF tc = TYPECODE(" & identfsTxt & ") THEN");
PutLine(wr,
IO.Put(\
Pickle.Special.rd for& self.basename &
.& identfsTxt &
: non-shared obj\\n\);
);
EndLine(wr, "obj := NEW(" & identfsTxt & ");"); Tab(wr, 2); PutLine(wr, "ELSE"); EndLine(wr, "RAISE Pickle.Error(\"Can't unpickle subtypes of " & self.basename & "." & identfTxt & "\");"); PutLine(wr, "END;");
PutLine(wr, IO.Put(\
Pickle.Special.rd for &
self.basename &
. & identfsTxt &
: reading space\\n\);
);
PutLine(wr, "space := in.read();");
PutLine(wr,
IO.Put(\
Pickle.Special.rd for& self.basename &
.& identfsTxt &
: reading shared obj\\n\);
);
PutLine(wr, "SharedObjStubLib.StartReadPickle(obj, in, space);"); Tab(wr,2); PutLine(wr, "LOCK sp" & identfTxt & ".mu DO"); EndLine(wr, "sp := sp" & identfTxt & ".sp;"); PutLine(wr, "END;"); PutLine(wr, "sp.read(obj, in);"); Tab(wr, 2); PutLine(wr, "IF tc = TYPECODE(" & identfTxt & ") THEN");
PutLine(wr,
IO.Put(\
Pickle.Special.rd for& self.basename &
.& identfsTxt &
: setup shared obj\\n\);
);
PutLine(wr, "obj := SharedObjStubLib.SetupNewCopy(obj, in, id, space);"); PutLine(wr, "proxy := PickleStubs.InRef(in);"); Tab(wr, 2); PutLine(wr, "IF obj.proxy = NIL THEN"); EndLine(wr, "obj.proxy := proxy;"); PutLine(wr, "END;"); EndLine(wr, "obj.makeProxy();"); Tab(wr, 2); PutLine(wr, "ELSE"); PutLine(wr, "obj.proxy := NIL;"); EndLine(wr, "obj.proxy := PickleStubs.InRef(in);"); PutLine(wr, "END;");
PutLine(wr, IO.Put(\
Pickle.Special.rd for &
self.basename &
. & identfsTxt &
: done\\n\);
);
EndLine(wr, "RETURN obj;"); EndLine(wr, "END " & procedureName & ";"); Nl(wr, freshLine := FALSE); Tab(wr, 2); procedureName := "RegisterSpecial_" & identfTxt; Put(wr, "PROCEDURE " & procedureName & " ("); PutLine(wr, "sp: " & identfTxt & "Special) ="); PutLine(wr, "<* FATAL DuplicateSpecial *>"); Tab(wr, 2); PutLine(wr, "BEGIN"); PutLine(wr, "(* we will need to NEW it here if RegisterSpecial_" & identfTxt); PutLine(wr, " is called from " & self.basename & " *)"); Tab(wr, 2); PutLine(wr, "IF sp" & identfTxt & " = NIL THEN"); Put(wr, "sp" & identfTxt & " := NEW("); Tab(wr, 0); Put(wr, identfTxt & "_Special, "); Br(wr); Put(wr, "sc := TYPECODE(" & identfsTxt & "), "); Br(wr); Put(wr, "mu := NEW(MUTEX)"); EndTab(wr); EndLine(wr, ");"); PutLine(wr, "END;"); Tab(wr, 2); PutLine(wr, "LOCK sp" & identfTxt & ".mu DO"); Tab(wr, 2); PutLine(wr, "IF sp" & identfTxt & ".registered THEN"); EndLine(wr, "RAISE DuplicateSpecial;"); PutLine(wr, "END;"); PutLine(wr, "sp" & identfTxt & ".registered := TRUE;"); EndLine(wr, "sp" & identfTxt & ".sp := sp;"); EndLine(wr, "END;"); EndLine(wr, "END " & procedureName & ";"); Nl(wr, freshLine := FALSE); Tab(wr, 2); PutLine(wr, "VAR"); EndLine(wr, "sp" & identfTxt & ": " & identfTxt & "_Special := NIL;"); (* Add to the initializers *) self.initializers := self.initializers & " IF sp" & identfTxt & " = NIL THEN\n sp" & identfTxt & " := NEW(" & identfTxt & "_Special,\n sc := TYPECODE(" & identfsTxt & "),\n mu := NEW(MUTEX),\n" & " sp := NEW(" & identfTxt & "Special));\n END;\n Pickle.RegisterSpecial(sp" & identfTxt & ");\n"; END; END Picklers; PROCEDUREMarshalTypedVal (fmtWr : Formatter.T; varName : TEXT; libName : TEXT; t : Type.T; d : Direction; calling : BOOLEAN; indexDepth := 0; maySuppress := FALSE) RAISES {SOxCodeGenError.E} = BEGIN TYPECASE t OF | Type.Char (ch) => Enumeration(fmtWr, varName, libName, ch, d, 0, ORD(LAST(CHAR))); | Type.UserDefined (ud) => Enumeration(fmtWr, varName, libName, t, d, 0, LAST(ud.elts^)); | Type.Subrange (sub) => IF t = Type.integer THEN StubLibCall(fmtWr, "Integer", varName, libName, d); ELSIF t = Type.longint THEN StubLibCall(fmtWr, "Longint", varName, libName, d); ELSE SubRange(fmtWr, varName, libName, t, d, sub.min, sub.max); END; | Type.Real => StubLibCall(fmtWr, "Real", varName, libName, d); | Type.LongReal => StubLibCall(fmtWr, "Longreal", varName, libName, d); | Type.Extended => StubLibCall(fmtWr, "Extended", varName, libName, d); | Type.Reference (r) => IF Type.MayBeRefAny(r) OR NOT Type.NamedType(r) THEN StubLibCall(fmtWr, "Ref", varName, libName, d, ", -1"); ELSE StubLibCall(fmtWr, "Ref", varName, libName, d, ", TYPECODE(" & CodeForType.ToText(r) & ")"); END; | Type.Array (a) => IF a.index = NIL THEN MarshalOpenArray(fmtWr, varName, libName, t, d, calling, indexDepth, maySuppress); ELSE BeginOutOnly(fmtWr, libName, t, d, maySuppress); Formatter.Begin(fmtWr, 2); PutLine(fmtWr, "FOR i" & Fmt.Int(indexDepth) & " := FIRST(" & CodeForType.ToText(a.index) & ") TO LAST(" & CodeForType.ToText(a.index) & ") DO"); MarshalTypedVal( fmtWr, varName & "[i" & Fmt.Int(indexDepth) & "]", libName, a.element, d, calling, indexDepth + 1); EndLine(fmtWr, "END;"); EndOutOnly(fmtWr, maySuppress); END; | Type.Packed (p) => BeginOutOnly(fmtWr, libName, t, d, maySuppress); MarshalTypedVal( fmtWr, varName, libName, p.base, d, calling, indexDepth); EndOutOnly(fmtWr, maySuppress); | Type.Record (rec) => BeginOutOnly(fmtWr, libName, t, d, maySuppress); FOR i := 0 TO LAST(rec.fields^) DO MarshalTypedVal( fmtWr, varName & "." & Atom.ToText(rec.fields[i].name), libName, rec.fields[i].type, d, calling, indexDepth); END; EndOutOnly(fmtWr, maySuppress); | Type.Set (s) => BeginOutOnly(fmtWr, libName, t, d, maySuppress); IF d = Direction.In THEN PutLine(fmtWr, varName & ":=" & CodeForType.ToText(s) & "{};"); Formatter.Begin(fmtWr, 2); PutLine(fmtWr, "FOR i" & Fmt.Int(indexDepth) & " := FIRST(" & CodeForType.ToText(s.range) & ") TO LAST(" & CodeForType.ToText(s.range) & ") DO"); Formatter.Begin(fmtWr, 2); PutLine(fmtWr, "IF " & libName & ".InBoolean(in) THEN"); PutLine(fmtWr, varName & " := " & varName & " + " & CodeForType.ToText(s) & "{i" & Fmt.Int(indexDepth) & "};"); EndLine(fmtWr, "END") ELSE Formatter.Begin(fmtWr, 2); PutLine(fmtWr, "FOR i" & Fmt.Int(indexDepth) & " := FIRST(" & CodeForType.ToText(s.range) & ") TO LAST(" & CodeForType.ToText(s.range) & ") DO"); PutLine(fmtWr, libName & ".OutBoolean(out, i" & Fmt.Int(indexDepth) & " IN " & varName & ");"); END; EndLine(fmtWr, "END;"); EndOutOnly(fmtWr, maySuppress); | Type.Procedure => RAISE SOxCodeGenError.E("Can't have a procedure as argument or result " & "of a network object method."); ELSE RAISE SOxCodeGenError.E("Run time error -- shouldn't occur"); END; END MarshalTypedVal; PROCEDURESubRange (fmtWr : Formatter.T; varName : TEXT; libName : TEXT; t : Type.Subrange; d : Direction; min, max: Value.T) RAISES {SOxCodeGenError.E}= BEGIN IF t = Type.longint OR t.base = Type.longint THEN WITH min = NARROW(min, Value.Longint).val, max = NARROW(max, Value.Longint).val DO StubLibCall(fmtWr, "Longint", varName, libName, d, ", " & Fmt.LongInt(min) & ", " & Fmt.LongInt(max)); END; ELSIF t = Type.integer OR t.base = Type.integer THEN WITH min = NARROW(min, Value.Integer).val, max = NARROW(max, Value.Integer).val DO StubLibCall(fmtWr, "Integer", varName, libName, d, ", " & Fmt.Int(min) & ", " & Fmt.Int(max)); END; ELSE TYPECASE t.base OF | Type.Enumeration => WITH min = NARROW(min, Value.Integer).val, max = NARROW(max, Value.Integer).val DO Enumeration(fmtWr, varName, libName, t.base, d, min, max); END; | Type.Subrange => SubRange(fmtWr, varName, libName, t.base, d, min, max); ELSE RAISE SOxCodeGenError.E("Run time error -- shouldn't occur"); END; END; END SubRange; PROCEDUREEnumeration (fmtWr : Formatter.T; varName : TEXT; libName : TEXT; t : Type.Enumeration; d : Direction; min, max: INTEGER ) = BEGIN IF d = Direction.In THEN PutLine(fmtWr, varName & " := VAL(" & libName & ".InInteger(in, " & Fmt.Int(min) & "," & Fmt.Int(max) & "), " & CodeForType.ToText(t) & ");"); ELSE PutLine(fmtWr, libName & ".OutInteger(out, ORD(" & varName & "));"); END; END Enumeration; PROCEDUREStubLibCall (fmtWr : Formatter.T; proc : TEXT; varName: TEXT; libName: TEXT; d : Direction; extra := "") = BEGIN IF d = Direction.In THEN PutLine(fmtWr, varName & " := " & libName & ".In" & proc & "(in" & extra & ");"); ELSE PutLine(fmtWr, libName & ".Out" & proc & "(out, " & varName & ");"); END; END StubLibCall; PROCEDUREStubLibCallNoRep (fmtWr : Formatter.T; proc : TEXT; varName: TEXT; libName: TEXT; d : Direction; extra := "") = BEGIN IF d = Direction.In THEN PutLine(fmtWr, varName & " := " & libName & ".In" & proc & "(in" & extra & ");"); ELSE PutLine(fmtWr, libName & ".Out" & proc & "(out, " & varName & ");"); END; END StubLibCallNoRep; PROCEDUREBeginOutOnly ( fmtWr : Formatter.T; libName : TEXT; <*UNUSED*> t : Type.T; d : Direction; maySuppress: BOOLEAN ) = VAR dataPresent := TRUE; (* Could check for size *) (* When recognizing pragma, dataPresent determined by methods[i].formals[j].outOnly *) BEGIN IF maySuppress THEN IF d = Direction.Out THEN PutLine(fmtWr, "dataPresent := " & Fmt.Bool(dataPresent) & ";"); END; StubLibCallNoRep(fmtWr, "Boolean", "dataPresent", libName, d); Formatter.Begin(fmtWr, 2); PutLine(fmtWr, "IF dataPresent THEN "); END; END BeginOutOnly; PROCEDUREEndOutOnly (fmtWr: Formatter.T; maySuppress: BOOLEAN) = BEGIN IF maySuppress THEN PutLine(fmtWr, "END;"); Formatter.End(fmtWr); END; END EndOutOnly; PROCEDUREMarshalOpenArray (fmtWr : Formatter.T; varName : TEXT; libName : TEXT; a : Type.OpenArray; d : Direction; calling : BOOLEAN; indexDepth : INTEGER; maySuppress: BOOLEAN ) RAISES {SOxCodeGenError.E} = VAR nDimensions := a.openDimensions; aName, baseName, boundList: Text.T; component : Type.T; BEGIN WITH Put = Formatter.PutText, Tab = Formatter.Begin, EndTab = Formatter.End DO IF calling THEN (* Must marshal/unmarshal array bounds *) IF d = Direction.Out THEN StubLibCall( fmtWr, "Integer", "NUMBER(" & varName & ")", libName, d); aName := varName & "[0"; FOR i := 2 TO nDimensions DO StubLibCall( fmtWr, "Integer", "NUMBER(" & aName & "])", libName, d); aName := aName & ", 0"; END; baseName := varName; ELSE Put(fmtWr, "WITH n1 = " & libName & ".InInteger(in)"); boundList := "n1"; FOR i := 2 TO nDimensions DO PutLine(fmtWr, ","); Put(fmtWr, " n" & Fmt.Int(i) & " = " & libName & ".InInteger(in)"); boundList := boundList & ", n" & Fmt.Int(i); END; PutLine(fmtWr, " DO"); PutLine(fmtWr, " " & varName & " := NEW(" & CodeForType.ToText(a.refArray) & ", " & boundList & ");"); PutLine(fmtWr, "END;"); baseName := varName & "^"; END; ELSE IF d = Direction.Out THEN baseName := varName & "^"; ELSE baseName := varName; END; END; (* Suppress actual data for <*OUTPUT*> params on call *) BeginOutOnly(fmtWr, libName, a, d, maySuppress); Tab(fmtWr, 2); PutLine(fmtWr, "FOR n1 := 0 TO LAST(" & baseName & ") DO"); aName := varName & "[n1"; component := a.element; FOR i := 2 TO nDimensions DO Tab(fmtWr, 2); PutLine( fmtWr, "FOR n" & Fmt.Int(i) & " := 0 TO LAST(" & aName & "]) DO"); aName := aName & ", n" & Fmt.Int(i); component := NARROW(component, Type.OpenArray).element; END; MarshalTypedVal( fmtWr, aName & "]", libName, component, d, calling, indexDepth); FOR i := 1 TO nDimensions DO EndTab(fmtWr); PutLine(fmtWr, "END;"); (* End FOR Loop *) END; EndOutOnly(fmtWr, maySuppress); END; END MarshalOpenArray; BEGIN END SOxModuleSOCode.