<> <> <> <> <> <<>> DIRECTORY Atom USING [GetPName, GetProp, PutProp, MakeAtom, FindAtom], BcdDefs USING [EVIndex, EVNull, EXPIndex, FTSelf, Link, MTIndex, MTRecord, NullVersion, TYPRecord, VarLimit, VersionStamp, BcdBase, EXPHandle, MTHandle, NameString, ModuleIndex], BcdOps USING [ProcessExports, ProcessModules], DebuggerSwap USING [CallDebugger], IO USING [PutFR], Loader USING [Error], LoaderOps USING [Pending, IR, GetPendingList, IsNullLink, SetPendingList, PendingModule, OpenLinkSpace, WriteLink, CloseLinkSpace, pendingModules, IRRecord], LoadState USING [local, Release, ConfigID, Acquire, EnumerateConfigs, ModuleInfo, ConfigInfo, BuildProcDescUsingModule], PrincOps USING [ControlLink, GlobalFrameHandle, NullLink], Rope USING [ROPE, Text, InlineLength, InlineFetch, FromProc], SafeStorage USING [GetPermanentZone], Table USING [Base]; CedarExporterImpl: PROGRAM IMPORTS Atom, BcdOps, DebuggerSwap, IO, Loader, LoaderOps, LoadState, Rope, SafeStorage EXPORTS LoaderOps = { OPEN BcdDefs, LoaderOps, Rope; <<********************************************************************>> <> <<********************************************************************>> Export: PUBLIC PROC [config: LoadState.ConfigID] = { bcd: BcdBase = LoadState.local.ConfigInfo[config].bcd; name: ROPE; toBeProcessed: LIST OF Pending; ftb: Table.Base = LOOPHOLE[bcd + bcd.ftOffset]; ssb: BcdDefs.NameString = LOOPHOLE[bcd + bcd.ssOffset]; ExportInterface: PROC [exph: EXPHandle, expi: EXPIndex] RETURNS [stop: BOOL _ FALSE] = { interface: IR; atom: ATOM; pending: LIST OF Pending; i: NAT _ 0; p: SAFE PROC RETURNS [c: CHAR] = TRUSTED{ c _ ssb.string.text[exph.name+i]; i _ i + 1; }; IF exph.port = module THEN RETURN; <> <> name _ Rope.FromProc[ssb.size[exph.name], p]; <<>> <> atom _ Atom.MakeAtom[name]; interface _ GetIR[atom, ftb[exph.file].version, exph.size].interface; <> FOR i: NAT IN [0..exph.size) DO IF IsNullLink[exph.links[i]] THEN LOOP; <> SELECT exph.links[i].vtag FROM var => { frame: PrincOps.GlobalFrameHandle; [interface[i], frame] _ FindVariableLink[config, exph.links[i].gfi, exph.links[i]]; IF frame # NIL THEN SaveFrame[interface, i, frame]; }; proc0, proc1 => interface[i] _ LoadState.local.BuildProcDescUsingModule[config, exph.links[i].gfi, exph.links[i].ep]; 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]}; }; <> [] _ BcdOps.ProcessExports[bcd, ExportInterface]; IF toBeProcessed # NIL THEN ProcessPendingEntries[toBeProcessed]; IF pendingModules # NIL THEN ExportModules[bcd, config]; }; ExportModules: PROC [bcd: BcdBase, config: LoadState.ConfigID] = { <> link: UNSPECIFIED; list, lastPending: LIST OF PendingModule; ftb: Table.Base = LOOPHOLE[bcd + bcd.ftOffset]; ssb: BcdDefs.NameString = LOOPHOLE[bcd + bcd.ssOffset]; Export: PROC [mth: MTHandle, mti: MTIndex] RETURNS [stop: BOOL _ FALSE] = { FOR list _ pendingModules, list.rest WHILE list # NIL DO len: INT; name: ROPE; 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; name _ list.first.name; len _ Rope.InlineLength[name]; IF len # ssb.size[mth.name] THEN LOOP; { FOR i: NAT IN NAT[0..len) DO IF Rope.InlineFetch[name, i] # ssb.string.text[mth.name+i] THEN GO TO notFound; ENDLOOP; EXITS notFound => LOOP; }; <> link _ LoadState.local.ModuleInfo[config, mth.gfi].gfh; OpenLinkSpace[list.first.frame, list.first.mth, list.first.bcd]; WriteLink[list.first.index, link]; CloseLinkSpace[list.first.frame]; <> list.first.frame _ NIL; ENDLOOP; }; <> [] _ 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; }; SaveResolvedEntries: PROC [process, pending: LIST OF Pending, interface: IR] RETURNS [newProcess, newPending: LIST OF Pending] = { <> <> 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 IsNullLink[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; }; ProcessPendingEntries: PROC [list: LIST OF Pending] = { frame: PrincOps.GlobalFrameHandle _ NIL; <> FOR list _ list, list.rest WHILE list # NIL DO IF list.first.frame # frame THEN { frame _ list.first.frame; 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; }; <<>> <<********************************************************************>> <> <<********************************************************************>> 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: ROPE] RETURNS [PrincOps.ControlLink] = { <> 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 _ 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: ROPE _ IO.PutFR["Exported Type Clash for interface %g, item#: %g", [rope[name]], [integer[i]] ]; ERROR Loader.Error[versionMismatch, typeError]; }; RETURN [LOOPHOLE[old]]; }; <<>> <<********************************************************************>> <> <<********************************************************************>> FindVariableLink: PUBLIC PROC [config: LoadState.ConfigID, mx: BcdDefs.ModuleIndex, mthLink: BcdDefs.Link] RETURNS [link: PrincOps.ControlLink, frame: PrincOps.GlobalFrameHandle] = { bcd: BcdBase = LoadState.local.ConfigInfo[config].bcd; 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 _ LoadState.local.ModuleInfo[config, mx].gfh; 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]; <> }; FindModule: PROC [bcd: BcdBase, gfi: BcdDefs.ModuleIndex] RETURNS [mth: MTHandle, ep: CARDINAL] = { <> 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]; }; <<>> <<********************************************************************>> <> <<********************************************************************>> frameIndex: NAT _ 0; frames: ExportedVariables _ NEW[ExportedVariablesSequence[500]]; 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] = { IF frame = NIL THEN RETURN; IF frameIndex >= frames.size THEN { -- allocate a larger one larger: ExportedVariables _ NEW[ExportedVariablesSequence[frames.size + 100]]; FOR i: NAT IN [0..frames.size) DO larger[i].interface _ frames[i].interface; larger[i].index _ frames[i].index; larger[i].frame _ frames[i].frame; ENDLOOP; frames _ larger}; frames[frameIndex] _ [interface, index, frame]; frameIndex _ frameIndex + 1; }; GetFrame: PUBLIC PROC [interface: IR, index: CARDINAL] RETURNS [PrincOps.GlobalFrameHandle] = { 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]; }; <<>> <<********************************************************************>> <> <<********************************************************************>> Zone: ZONE _ SafeStorage.GetPermanentZone[]; suspect: ATOM _ NIL; GetIR: PUBLIC PROC [atom: ATOM, version: BcdDefs.VersionStamp, length: CARDINAL] RETURNS [name: ATOM, interface: IR, versionStamp: BcdDefs.VersionStamp] = { 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 { <> old _ Zone.NEW[VersionStamp _ version]; Atom.PutProp[atom, $version, old]; } ELSE <> IF version # old^ THEN Loader.Error[versionMismatch, 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 { IF atom = suspect THEN <> DebuggerSwap.CallDebugger["Follow that car!"L]; interface _ Zone.NEW[IRRecord[length]]; Atom.PutProp[atom, $IR, interface]; }; RETURN [atom, interface, IF old = NIL THEN NullVersion ELSE old^]; }; FindAtom: PROC [version: BcdDefs.VersionStamp] RETURNS [atom: ATOM] = { CheckVersion: SAFE PROC [atom: ATOM] RETURNS [stop: BOOL] = 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 _ Atom.FindAtom[CheckVersion]; }; Initialize: PROC = { ENABLE UNWIND => {LoadState.local.Release[]}; proc: PROC [config: LoadState.ConfigID] RETURNS [stop: BOOL _ FALSE] = {Export[config]}; LoadState.local.Acquire[exclusive]; [] _ LoadState.local.EnumerateConfigs[oldestFirst, proc]; LoadState.local.Release[]; }; Initialize[]; } . . .