<> <> <> <> DIRECTORY Atom USING [GetPName, GetProp, PutProp], AtomsPrivate USING [EnumerateAtoms, UnsafeMakeAtom], BcdDefs USING [ EVIndex, EVNull, EXPIndex, FTSelf, Link, MTIndex, MTRecord, NullVersion, TYPRecord, VarLimit, VersionStamp], BcdOps USING [ BcdBase, EXPHandle, MTHandle, NameString, ProcessExports, ProcessModules], CedarLinkerOps, <> Loader USING [Error], LongString USING [AppendString, AppendDecimal], PilotLoadStateOps USING [ AcquireBcd, ConfigIndex, InputLoadState, GetMap, Map, ReleaseBcd, ReleaseLoadState, ReleaseMap], PrincOps USING [ ControlLink, GFTIndex, GlobalFrameHandle, NullLink], PrincOpsRuntime USING [GetFrame, GFT], Rope USING [Text], SafeStorage USING [NewZone], Table USING [Base]; CedarExporterImpl: PROGRAM IMPORTS Atom, AtomsPrivate, BcdOps, CedarLinkerOps, Loader, PilotLoadStateOps, PrincOpsRuntime, SafeStorage, String: LongString EXPORTS CedarLinkerOps SHARES Rope = BEGIN OPEN BcdDefs, BcdOps, CedarLinkerOps; <<********************************************************************>> <> <> <> <> <<********************************************************************>> Export: PUBLIC PROC[bcd: BcdBase, map: PilotLoadStateOps.Map] = BEGIN maxInterfaceNameLength: NAT = 40; name: STRING = [maxInterfaceNameLength]; toBeProcessed: LIST OF Pending; ftb: Table.Base = LOOPHOLE[bcd + bcd.ftOffset]; ssb: BcdOps.NameString = LOOPHOLE[bcd + bcd.ssOffset]; ExportInterface: PROC[exph: EXPHandle, expi: EXPIndex] RETURNS[stop: BOOLEAN _ FALSE] = BEGIN interface: IR; atom: ATOM; rgfi: PrincOps.GFTIndex; pending: LIST OF Pending; <> name.length _ 0; FOR i: NAT IN [0..ssb.size[exph.name]) DO m: STRING = "interface name too long"; IF name.length = maxInterfaceNameLength THEN ERROR Loader.Error[type: invalidBcd, message: LOOPHOLE[LONG[m]]]; name[name.length] _ ssb.string.text[exph.name+i]; name.length _ name.length+1; ENDLOOP; <> atom _ AtomsPrivate.UnsafeMakeAtom[LOOPHOLE[LONG[name]]]; interface _ GetIR[atom, ftb[exph.file].version, exph.size].interface; <> FOR i: NAT IN [0..exph.size) DO IF NullLink[exph.links[i]] THEN LOOP; <> rgfi _ map[exph.links[i].gfi]; -- determine the real gfi SELECT exph.links[i].vtag FROM var => {frame: PrincOps.GlobalFrameHandle; [interface[i], frame] _ FindVariableLink[bcd, exph.links[i], rgfi]; IF frame # NIL THEN SaveFrame[interface, i, frame]}; proc0, proc1 => interface[i] _ [procedure[gfi: rgfi, ep: exph.links[i].ep, tag: TRUE]]; type => interface[i] _ CheckType[bcd, exph.links[i], LOOPHOLE[interface[i]], i, name]; ENDCASE => ERROR; ENDLOOP; <> pending _ GetPendingList[atom]; IF pending # NIL THEN { [toBeProcessed, pending] _ SaveResolvedEntries[toBeProcessed, pending, interface]; SetPendingList[atom, pending]}; END; <> [] _ BcdOps.ProcessExports[bcd, ExportInterface]; IF toBeProcessed # NIL THEN ProcessPendingEntries[toBeProcessed]; IF pendingModules # NIL THEN ExportModules[bcd, map]; END; ExportModules: PROC[bcd: BcdBase, map: PilotLoadStateOps.Map] = BEGIN -- check to see if this bcd has a module that someone is waiting for. link: UNSPECIFIED; list, lastPending: LIST OF PendingModule; ftb: Table.Base = LOOPHOLE[bcd + bcd.ftOffset]; ssb: BcdOps.NameString = LOOPHOLE[bcd + bcd.ssOffset]; Export: PROC[mth: MTHandle, mti: MTIndex] RETURNS[stop: BOOLEAN _ FALSE] = BEGIN found: BOOLEAN; FOR list _ pendingModules, list.rest WHILE list # NIL DO IF mth.file = BcdDefs.FTSelf THEN IF list.first.version # bcd.version THEN LOOP ELSE NULL ELSE IF list.first.version # ftb[mth.file].version THEN LOOP; found _ TRUE; IF list.first.name.length # ssb.size[mth.name] THEN LOOP; FOR i: NAT IN [0..list.first.name.length) DO IF list.first.name.text[i] # ssb.string.text[mth.name+i] THEN {found _ FALSE; EXIT}; ENDLOOP; IF ~found THEN LOOP; <> link _ PrincOpsRuntime.GetFrame[PrincOpsRuntime.GFT[map[mth.gfi]]]; CedarLinkerOps.OpenLinkSpace[list.first.frame, list.first.mth, list.first.bcd]; CedarLinkerOps.WriteLink[list.first.index, link]; CedarLinkerOps.CloseLinkSpace[list.first.frame]; <> list.first.frame _ NIL; ENDLOOP; END; <> [] _ BcdOps.ProcessModules[bcd, Export]; <> FOR list _ pendingModules, list.rest WHILE list # NIL DO IF list.first.frame # NIL THEN {lastPending _ list; LOOP}; IF lastPending = NIL THEN pendingModules _ list.rest ELSE lastPending.rest _ list.rest; ENDLOOP; END; SaveResolvedEntries: PROC[process, pending: LIST OF Pending, interface: IR] RETURNS[newProcess, newPending: LIST OF Pending] = BEGIN -- move resolved pending items to the 'toBeProcessed' list. <> index: NAT; next, lastPending: LIST OF Pending; newProcess _ process; newPending _ pending; <> FOR pending _ pending, next WHILE pending # NIL DO next _ pending.rest; -- 'rest' may be changed index _ LOOPHOLE[pending.first.link]; IF NullLink[interface[index]] THEN {lastPending _ pending; LOOP}; pending.first.link _ interface[index]; -- redefines 'link' <> IF lastPending # NIL THEN lastPending.rest _ next ELSE newPending _ next; <> <> IF newProcess = NIL OR LOOPHOLE[pending.first.frame, CARDINAL] < LOOPHOLE[newProcess.first.frame, CARDINAL] THEN { pending.rest _ newProcess; newProcess _ pending; LOOP}; <> FOR process _ newProcess, process.rest DO IF process.rest = NIL OR LOOPHOLE[pending.first.frame, CARDINAL] < LOOPHOLE[process.rest.first.frame, CARDINAL] THEN { pending.rest _ process.rest; process.rest _ pending; EXIT}; ENDLOOP; ENDLOOP; END; ProcessPendingEntries: PROC[list: LIST OF Pending] = BEGIN OPEN CedarLinkerOps; frame: PrincOps.GlobalFrameHandle _ NIL; <> FOR list _ list, list.rest WHILE list # NIL DO IF list.first.frame # frame THEN OpenLinkSpace[list.first.frame, list.first.mth, list.first.bcd]; WriteLink[list.first.index, list.first.link]; IF list.rest = NIL OR list.rest.first.frame # frame THEN CloseLinkSpace[frame]; ENDLOOP; END; <<>> <<********************************************************************>> <> <<'types'. We want to check that there is at most one concrete type for each opaque type. >> <> <> <<********************************************************************>> typeIndex: NAT _ 0; types: ExportedTypes _ NEW[ExportedTypesSequence[100]]; ExportedTypes: TYPE = REF ExportedTypesSequence; ExportedTypesSequence: TYPE = RECORD[s: SEQUENCE size: NAT OF BcdDefs.TYPRecord]; CheckType: PROC[bcd: BcdBase, new, old: BcdDefs.Link, i: NAT, name: STRING] RETURNS[PrincOps.ControlLink] = BEGIN -- compare the old type with the one we want to export. oldIndex: NAT = LOOPHOLE[old.typeID]; typb: Table.Base = LOOPHOLE[bcd + bcd.typOffset]; IF oldIndex = 0 THEN { -- first time exported. <> FOR i: NAT IN [1..typeIndex) DO IF types[i] # typb[new.typeID] THEN LOOP; old _ [type[typeID: LOOPHOLE[i], type: new.type, proc: new.proc]]; RETURN[LOOPHOLE[old]]; ENDLOOP; <> typeIndex _ typeIndex + 1; IF typeIndex >= types.size THEN { -- allocate a large one larger: ExportedTypes _ Zone.NEW[ExportedTypesSequence[types.size + 100]]; FOR i: NAT IN [0..types.size) DO larger[i] _ types[i]; ENDLOOP; types _ larger}; types[typeIndex] _ typb[new.typeID]; old _ [type[typeID: LOOPHOLE[typeIndex], type: new.type, proc: new.proc]]; RETURN[LOOPHOLE[old]]}; <> IF types[oldIndex] # typb[new.typeID] THEN { typeError: STRING = [100]; String.AppendString[typeError, "Exported Type Clash for interface "L]; String.AppendString[typeError, name]; String.AppendString[typeError, ", item # "L]; String.AppendDecimal[typeError, i]; ERROR Loader.Error[versionMismatch, LOOPHOLE[LONG[typeError]]]}; RETURN[LOOPHOLE[old]]; END; <<>> <<********************************************************************>> <> <<********************************************************************>> FindVariableLink: PUBLIC PROC[ bcd: BcdBase, mthLink: BcdDefs.Link, rgfi: PrincOps.GFTIndex] RETURNS [link: PrincOps.ControlLink, frame: PrincOps.GlobalFrameHandle] = BEGIN ep: CARDINAL; evi: EVIndex; evb: Table.Base; mth: MTHandle; [mth, ep] _ FindModule[bcd, mthLink.vgfi]; IF mth = NIL THEN RETURN[PrincOps.NullLink, NIL]; evb _ LOOPHOLE[bcd + bcd.evOffset, Table.Base]; frame _ PrincOpsRuntime.GetFrame[PrincOpsRuntime.GFT[rgfi]]; IF (ep _ ep + mthLink.var) = 0 THEN RETURN[LOOPHOLE[frame], NIL]; <> IF (evi _ mth.variables) = EVNull THEN RETURN[PrincOps.NullLink, NIL]; RETURN[LOOPHOLE[frame + evb[evi].offsets[ep]], frame]; <> END; -- end FindVariableLink FindModule: PROC[bcd: BcdBase, gfi: PrincOps.GFTIndex] RETURNS[mth: MTHandle, ep: CARDINAL] = BEGIN -- expansion of BcdOps.ProcessModules[bcd, FindModule] mti: MTIndex; mtb: Table.Base = LOOPHOLE[bcd + bcd.mtOffset]; i: CARDINAL; mti _ FIRST[MTIndex]; FOR i IN [0..bcd.nModules) DO mth _ @mtb[mti]; <<~~~~~~~~~~~~~~~~~~~~~~~~>> IF gfi IN [mth.gfi..mth.gfi+mth.ngfi) THEN RETURN[mth, VarLimit*(gfi - mth.gfi)]; <<~~~~~~~~~~~~~~~~~~~~~~~~>> mti _ mti + (WITH m: mtb[mti] SELECT FROM direct => SIZE[MTRecord[direct]] + m.length*SIZE[Link], indirect => SIZE[MTRecord[indirect]], multiple => SIZE[MTRecord[multiple]], ENDCASE => ERROR) ENDLOOP; RETURN[NIL, 0]; END; <<>> <<********************************************************************>> <> <<********************************************************************>> frameIndex: NAT _ 0; frames: ExportedVariables _ NEW[ExportedVariablesSequence[10]]; ExportedVariables: TYPE = REF ExportedVariablesSequence; ExportedVariablesSequence: TYPE = RECORD[s: SEQUENCE size: NAT OF VariableRecord]; VariableRecord: TYPE = RECORD[ interface: IR, index: CARDINAL, frame: PrincOps.GlobalFrameHandle]; SaveFrame: PROC[interface: IR, index: CARDINAL, frame: PrincOps.GlobalFrameHandle] = BEGIN IF frame = NIL THEN RETURN; IF frameIndex >= frames.size THEN { -- allocate a larger one larger: ExportedVariables _ Zone.NEW[ExportedVariablesSequence[frames.size + 10]]; FOR i: NAT IN [0..frames.size) DO larger[i] _ frames[i]; ENDLOOP; frames _ larger}; frames[frameIndex] _ [interface, index, frame]; frameIndex _ frameIndex + 1; END; GetFrame: PUBLIC PROC[interface: IR, index: CARDINAL] RETURNS[PrincOps.GlobalFrameHandle] = BEGIN FOR i: CARDINAL DECREASING IN [0..frameIndex) DO -- decreasing to catch last export IF frames[i].interface # interface THEN LOOP; IF frames[i].index # index THEN LOOP; RETURN[frames[i].frame]; ENDLOOP; RETURN[NIL]; END; <<>> <<********************************************************************>> <> <<********************************************************************>> Zone: ZONE _ SafeStorage.NewZone[]; GetIR: PUBLIC PROCEDURE[ atom: ATOM, version: BcdDefs.VersionStamp, length: CARDINAL] -- in case a new one must be created RETURNS[name: ATOM, interface: IR, versionStamp: BcdDefs.VersionStamp] = BEGIN old: REF BcdDefs.VersionStamp; IF atom = NIL THEN atom _ FindAtom[version]; IF atom = NIL THEN RETURN[NIL, NIL, NullVersion]; IF version # NullVersion THEN IF (old _ NARROW[Atom.GetProp[atom, $version]]) = NIL THEN {-- create a new one old _ Zone.NEW[VersionStamp _ version]; Atom.PutProp[atom, $version, old]} ELSE IF version # old^ THEN -- check version mismatch Loader.Error[versionMismatch, LOOPHOLE[Atom.GetPName[atom]]]; interface _ NARROW[Atom.GetProp[atom, $IR]]; IF length = 0 THEN RETURN[atom, interface, IF old = NIL THEN NullVersion ELSE old^]; IF interface = NIL THEN { interface _ Zone.NEW[IRRecord[length]]; Atom.PutProp[atom, $IR, interface]}; RETURN[atom, interface, IF old = NIL THEN NullVersion ELSE old^]; END; FindAtom: PROCEDURE[version: BcdDefs.VersionStamp] RETURNS[atom: ATOM] = BEGIN CheckVersion: SAFE PROC[atom: ATOM] RETURNS[stop: BOOLEAN] = TRUSTED { old: REF BcdDefs.VersionStamp; old _ NARROW[Atom.GetProp[atom, $version]]; IF old = NIL THEN RETURN[stop: FALSE]; RETURN[stop: old^ = version]}; IF version = BcdDefs.NullVersion THEN RETURN[NIL]; atom _ AtomsPrivate.EnumerateAtoms[CheckVersion]; END; Initialize: PROC = BEGIN OPEN PilotLoadStateOps; ENABLE UNWIND => {ReleaseLoadState[]}; map: Map; bcd: BcdBase; nbcds: ConfigIndex _ InputLoadState[]; FOR i: NAT IN [0..nbcds) DO bcd _ AcquireBcd[i]; map _ GetMap[i]; Export[bcd, map]; ReleaseMap[map]; ReleaseBcd[bcd]; ENDLOOP; ReleaseLoadState[]; END; Initialize[]; END . . .