ValuesImpl.mesa
Copyright © 1986 by Xerox Corporation. All rights reserved.
Created by Christian Jacobi, July 25, 1986 3:47:50 pm PDT
Last Edited by: Jacobi July 28, 1986 1:02:21 pm PDT
DIRECTORY
Atom,
HashTable,
PropertyLists,
SafeStorage,
Values;
ValuesImpl:
CEDAR
MONITOR
IMPORTS Atom, PropertyLists, SafeStorage, HashTable
EXPORTS Values
SHARES HashTable =
BEGIN
MONITOR invariants
Never crash inside monitor [not even if unwind is used],
because we want allow independent clients to make calls on different types
Fetch, Store, Insert, Propagate, DefaultInsert are not monitored; Otherwise, a client
could cause a wedge by recursively using Values again.
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.