<> <> <> <> DIRECTORY Atom, HashTable, PropertyLists, SafeStorage, Values; ValuesImpl: CEDAR MONITOR IMPORTS Atom, PropertyLists, SafeStorage, HashTable EXPORTS Values SHARES HashTable = BEGIN <> <> <> <> <> StoreProc: TYPE = Values.StoreProc; FetchProc: TYPE = Values.FetchProc; InsertProc: TYPE = Values.InsertProc; PropagateProc: TYPE = Values.PropagateProc; TypeTab: TYPE = PACKED ARRAY SafeStorage.TypeIndex OF REF; typeTab: REF TypeTab _ SafeStorage.GetPermanentZone[].NEW[TypeTab_ALL[NIL]]; keyTab: HashTable.Table ~ HashTable.Create[51]; NotRegisteredType: PUBLIC SIGNAL = CODE; ReRegistration: PUBLIC ERROR = CODE; Reg: TYPE = REF RegRec; RegRec: TYPE = RECORD [ store: StoreProc _ NilStore, fetch: FetchProc _ NilFetch, insert: InsertProc _ DefaultInsert, propagate: PropagateProc _ NilPropagate, occupied: BOOL _ FALSE, registrationKey: REF _ NIL, prop: PropertyLists.PropList _ NIL ]; NilStore: StoreProc = {}; NilFetch: FetchProc = {}; NilPropagate: PropagateProc = {}; retry: CONDITION; Enter: ENTRY PROC [r: Reg] = { ENABLE UNWIND => NULL; WHILE r.occupied DO WAIT retry ENDLOOP; r.occupied _ TRUE }; Leave: ENTRY PROC [r: Reg] = { ENABLE UNWIND => NULL; r.occupied _ FALSE; BROADCAST retry }; DefaultInsert: InsertProc = { r: Reg _ GetReg[onto]; IF r=NIL THEN SIGNAL NotRegisteredType ELSE { ENABLE UNWIND => Leave[r]; Enter[r]; IF done _ r.fetch[onto, key]=NIL THEN r.store[onto, key, val]; Leave[r]; } }; GetReg: PROC [from: REF] RETURNS [Reg] = INLINE { WITH typeTab[SafeStorage.GetCanonicalReferentType[from]] SELECT FROM r: Reg => RETURN [r]; ENDCASE => RETURN [NIL]; }; Store: PUBLIC PROC [onto: REF, key: REF, val: REF_NIL] = { r: Reg _ GetReg[onto]; IF r=NIL THEN SIGNAL NotRegisteredType ELSE r.store[onto, key, val] }; Insert: PUBLIC PROC [onto: REF, key: REF, val: REF] RETURNS [done: BOOL_FALSE] = { r: Reg _ GetReg[onto]; IF r=NIL THEN SIGNAL NotRegisteredType ELSE done _ r.insert[onto, key, val] }; Fetch: PUBLIC PROC [from: REF, key: REF, propagate: BOOL_TRUE] RETURNS [val: REF_NIL] = { DO r: Reg _ GetReg[from]; IF r=NIL THEN {propagate_FALSE; SIGNAL NotRegisteredType} ELSE val _ r.fetch[from, key]; IF val#NIL OR ~propagate THEN RETURN; from _ r.propagate[from]; IF from=NIL THEN RETURN ENDLOOP }; Propagate: PUBLIC PROC [from: REF] RETURNS [to: REF_NIL] = { r: Reg _ GetReg[from]; IF r=NIL OR from=NIL THEN SIGNAL NotRegisteredType ELSE to _ r.propagate[from] }; RegisterKey: PUBLIC ENTRY PROC [key: REF, registrationKey: REF _ NIL] = { ENABLE UNWIND => NULL; x: REF _ keyTab.Fetch[key].value; IF registrationKey=NIL THEN registrationKey _ keyTab; IF x=NIL THEN [] _ keyTab.Store[key, registrationKey] ELSE IF x=registrationKey THEN RETURN WITH ERROR ReRegistration }; RegisterType: PUBLIC ENTRY PROC [referentType: SafeStorage.Type, store: StoreProc _ NIL, fetch: FetchProc _ NIL, insert: InsertProc _ NIL, propagate: PropagateProc _ NIL, registrationKey: REF _ NIL] = { ENABLE UNWIND => NULL; r: Reg_NIL; pl: PropertyLists.PropList_NIL; referentType _ SafeStorage.GetCanonicalType[referentType]; WITH typeTab[referentType] SELECT FROM rr: Reg => r _ rr; rpl: PropertyLists.PropList => pl _ rpl ENDCASE; IF r=NIL THEN r _ typeTab[referentType] _ NEW[RegRec_[registrationKey: registrationKey, prop: pl]] ELSE IF registrationKey=NIL OR registrationKey#r.registrationKey THEN RETURN WITH ERROR ReRegistration; IF store#NIL THEN r.store _ store; IF fetch#NIL THEN r.fetch _ fetch; IF insert#NIL THEN r.insert _ insert; IF propagate#NIL THEN r.propagate _ propagate; }; <<--some pre-registered clients>> <<--they all don't propagate>> <<--Catch usage of NIL>> ErrStore: StoreProc = {ERROR}; ErrFetch: FetchProc = {ERROR}; ErrInsert: InsertProc = {ERROR}; <<>> <<--PropertyLists>> <<--only fetch is allowed; supported only for nice propagations>> RPLFetch: FetchProc = { pl: PropertyLists.PropList _ NARROW[from]; val _ PropertyLists.GetProp[pl, key]; }; PLFetch: FetchProc = { val _ PropertyLists.GetProp[NARROW[from], key]; }; APLFetch: FetchProc = { val _ Atom.GetPropFromList[NARROW[from], key]; }; <<>> <<--HashTables>> <<--must not be monitored, since could crash in HashTable client code>> HStore: StoreProc = { IF val#NIL THEN [] _ HashTable.Store[NARROW[onto], key, val] ELSE [] _ HashTable.Delete[NARROW[onto], key] }; HFetch: FetchProc = { val _ HashTable.Fetch[NARROW[from], key].value; }; HInsert: InsertProc = { IF val#NIL THEN [done] _ HashTable.Insert[NARROW[onto], key, val] }; <<--Atoms>> <<--use of own mechanism to guarantee uniqueness of registered keys>> atomTab: HashTable.Table ~ HashTable.Create[17]; AStore: ENTRY StoreProc = { ENABLE UNWIND => NULL; pl, npl: PropertyLists.PropList; pl _ NARROW[atomTab.Fetch[onto].value]; --no crash: proc is not called if onto not atom npl _ PropertyLists.PutProp[pl, key, val]; IF pl#npl THEN [] _ atomTab.Store[onto, npl] }; AInsert: ENTRY InsertProc = { ENABLE UNWIND => NULL; pl, npl: PropertyLists.PropList; pl _ NARROW[atomTab.Fetch[onto].value]; IF done _ PropertyLists.GetProp[pl, key]=NIL THEN { npl _ PropertyLists.PutProp[pl, key, val]; IF pl#npl THEN [] _ atomTab.Store[onto, npl] } }; AFetch: FetchProc = { pl: PropertyLists.PropList ~ NARROW[atomTab.Fetch[from].value]; val _ PropertyLists.GetProp[pl, key]; }; <<>> <<--Types>> <<--the main reason why types are included, is to make better use of the huge >> <<--array declared anyway for the registrations>> TStore: ENTRY StoreProc = { ENABLE UNWIND => NULL; tr: SafeStorage.Type; tr _ NARROW[onto, REF SafeStorage.Type]^; --no crash: proc is not called if onto wrong type WITH typeTab[tr] SELECT FROM pl: PropertyLists.PropList => typeTab[tr] _ PropertyLists.PutProp[pl, key, val]; r: Reg => r.prop _ PropertyLists.PutProp[r.prop, key, val]; ENDCASE => typeTab[tr] _ PropertyLists.PutProp[NIL, key, val]; }; TInsert: ENTRY InsertProc = { ENABLE UNWIND => NULL; tr: SafeStorage.Type; tr _ NARROW[onto, REF SafeStorage.Type]^; WITH typeTab[tr] SELECT FROM pl: PropertyLists.PropList => IF done _ PropertyLists.GetProp[pl, key]=NIL THEN typeTab[tr] _ PropertyLists.PutProp[pl, key, val]; r: Reg => IF done _ PropertyLists.GetProp[r.prop, key]=NIL THEN r.prop _ PropertyLists.PutProp[r.prop, key, val]; ENDCASE => typeTab[tr] _ PropertyLists.PutProp[NIL, key, val]; }; TFetch: FetchProc = { WITH typeTab[NARROW[from, REF SafeStorage.Type]^] SELECT FROM pl: PropertyLists.PropList => val _ PropertyLists.GetProp[pl, key]; rr: Reg => val _ PropertyLists.GetProp[rr.prop, key]; ENDCASE => NULL }; RegisterType[SafeStorage.nullType, ErrStore, ErrFetch, ErrInsert]; RegisterType[SafeStorage.GetCanonicalReferentType[$a], AStore, AFetch, AInsert]; RegisterType[CODE[SafeStorage.Type], TStore, TFetch, TInsert]; RegisterType[CODE[HashTable.TableRec], HStore, HFetch, HInsert]; RegisterType[SafeStorage.GetCanonicalReferentType[PropertyLists.PutProp[NIL, $a, $a]], ErrStore, PLFetch, ErrInsert]; RegisterType[CODE[PropertyLists.PropList], ErrStore, RPLFetch, ErrInsert]; RegisterType[SafeStorage.GetCanonicalReferentType[Atom.PutPropOnList[NIL, $a, $a]], ErrStore, APLFetch, ErrInsert]; END.