|
DataMuseum.dkPresents historical artifacts from the history of: Bogika Butler |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Bogika Butler Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 91776 (0x16680)
Types: TextFile
Names: »OBJDIR.SA«
└─⟦2322e079b⟧ Bits:30009789/_.ft.Ibm2.50006594.imd Mogens Pelles Zilog 80,000 / EOS projekt
└─⟦this⟧ »OBJDIR.SA«
└─⟦311ba069f⟧ Bits:30009789/_.ft.Ibm2.50006625.imd Mogens Pelles Zilog 80,000 / EOS projekt
└─⟦this⟧ »OBJDIR.SA«
└─⟦49237ce80⟧ Bits:30009789/_.ft.Ibm2.50006627.imd Mogens Pelles Zilog 80,000 / EOS projekt
└─⟦this⟧ »OBJDIR.SA«
æ*****************************************************************
Copyright 1984 by
NCR Corporation
Dayton, Ohio U.S.A.
All Rights Reserved
******************************************************************
EOS Software produced by:
NCR Systems Engineering - Copenhagen
Copenhagen
DENMARK
*****************************************************************å
æ Ver. 0.29 å
æ$h=0å æ no heap space å
æ$L-å
(*
S T U B
M O D U L E
(OBJECT DIRECTORY)
for EOS - Operating System.
A Stub Object serves as a directory of objects and pointers.
The Stub either owns or manages the objects.
A Stub may load an Installation Module and create
a Callable general object or a Library Module.
The objects and pointers of a Stub may be protected
by utilizing the Security object.
During bootstrap the Stub is the first object called by
the kernel's Boot Process. The Stub loads a configuration
module and calls it, to take care of creating other
objects and configurating then.
Copyright NCR Corp. 1982
Written: August 1982
By: Peter Mikkelsen, SE-Copenhagen.
Version id: 00/00
Last update: 82-08-09
*)
(*$e*)
(*
OVERVIEW OF THE MODULE'S TEXT: PAGE
Export description 5
Import description 10
Stub constants and types 12
Global routines:
Auxiliary routines:
- Setforeign 16
- RealError 17
- GetNextRec 18
- concatNames 19
- getShortid 20
- VerifyOperation 20.2
Routines to handle bucket entries:
- LockEntry 21
- lookup 22
- OccupyFree 23
- CleanUpEntry 24
Search routines:
- GetRefSimple 25
- GetRefComplete 26
Global version of Stub entry-routines:
- GlobalInsertPtr 27
- GlobalGetRef 29
- GlobalDelete 31
The central installation routine:
- Install 32
OBJECT Stub 56
Local routines:
- CheckNewName 57
- CheckOldName 58
Private routines:
- AddBucket 59
Entry routines:
- Init 60
- UseAlloc 61
- UseSecurity 61
- Load 62
- Create 63
- CreateAccess 64
- InsertPointer 66
- NewStub 67
- GetRef 69
- ReName 70
- Delete 71
- Abort 72
- AbortAll 73
- GetStubName 74
- InitScan 75
- DeleteSubStub 76
OBJECT Scan 77
Entry routine:
- GetInf 77
Installation description 78
*)
Object program STUB;
æ$l+å
æ ------------------ Include import descriptions of modules -------------å
æ$F=family.univ.id,l-å
æ$l+å
æ$F=family.knel.id,l-å
æ$l+å
æ$F=family.iosys.id,l-å
æ$l+å
æ$F=family.sched.id,l-å
æ$l+å
æ$F=family.alloc.id,l-å
æ$L+å
æ------------------ External test output procedures -------------------å
type
txt = array Æ1..addrmaxÅ of char;
txtptr = ^ ÆÅ txt;
procedure PrintText ( t: txtptr ); æexternalå forward;
procedure PrintStack( t: txtptr ); æexternalå forward;
procedure Printvar ( t: txtptr; univ v: blockptr); æexternalå forward;
procedure setTstFlg ( flg: integer ); æexternalå forward;
function getTstFlg: integer; æexternalå forward;
PROCEDURE check
(res: resultType);
BEGIN
if res.main<>ok then printVar('*** ObjDir Check *** res=',res);
IF res.main<>ok THEN exception(res);
END æ***check***å;
PROCEDURE StopCheck
(res: resultType);
BEGIN
æ#b#PrintVar('*** ObjDir StopCheck *** res=',res);#e#å
IF res.main<>ok THEN exception(res);
END æ***StopCheck***å;
PROCEDURE NoCheck
(res: resultType);
BEGIN
æ#b#printVar('*** ObjDir NoCheck *** res=',res);#e#å
END æ***NoCheck***å;
æ---------------- ObjDir definition ---------------------------------å
æ$F=family.objdir.idå
æ------------------- Common Types ---------------------------å
type
maxBufBlock = array Æ0..addrMaxÅ of byte;
bufPtr = ^ ÆÅ maxBufBlock;
bufferRef = ^^ÆÅ maxBufBlock;
name16 = array Æ1..16Å of char;
nameMax= array Æ1..99Å of char;
(* Installation Module types *)
TYPE
headerprefix = RECORD (* size = 56 bytes *)
size: word;
sizeofModule: long;
kind: word; (* 0 = programModule, 1 = libraryModule *)
addressProgObjDescr: word;
(* Export Descr *)
objectName: name16;
noEntryDescrs: word; (* = 0 *)
noLocalObjDescrs: word; (* = 0 *)
(* Import descr *)
noImportedObjDescrs: word; (* = 0 *)
noSymbLibDescrs: word; (* = 0 *)
(* program Object Description *)
addFirstLocDatSegmDescr: word;
noLocPtrs: word;
noTempPtrs: word;
sizetempData: long;
callStack: sizeType;
entryAddress: long;
noObjectRefs: word;
noLocDatsegms: word;
END;
Objrefdescr = RECORD (* size = 18 bytes *)
name: name16;
locPtrIndex: word;
END;
LocdatSegmDescr = RECORD (* size = 28 bytes *)
size: word; (* of description *)
name: name16;
locPtrIndex: word;
options: word;
sizeOfSegm: long;
noLoadSections: word;
END;
LdSctDescr = RECORD (* size = 12 bytes *)
relStartAddr: long;
length: long;
addOfContents: long;
END;
ModifDescr = RECORD (* size = 12 bytes *)
noFunctCodeRefs: word; (* = 0 *)
noImportedSymbRefs: word; (* = 0 *)
(* ReLocation Information *)
assumedLogicalStartAddr: long;
relocatable: word; (* 0 = no, 1 = yes *) (* = 0 *)
noAddrModifs: word; (* = 0 *)
end;
(* STUB CONSTANTS *)
CONST
SubStubsIndex = 13 ; (* The pointer-number of "SubStubs" *)
AllocName = 'allocate ';
SchedName = 'scheduler ';
IntName = 'intscheduler ';
ConfigName = 'initconfig ';
EgoObjName = '* ';
EgoEnvName = '** ';
RootName = '/ ';
ObjDirName = 'objdir ';
NULL = ' ';
BucketSize = 20;
NoOfPrefixes = 10;
ShortidLength = 16;
Slash = '/';
ObjDirOrg = 0; æ SE-CP å
ObjDirSys = 5000;
initUserSize = 80000;
initKernelSize = 8000;
(* Aux error codes *)
stringTooShort = 1;
nameError = 2;
nameMissing = 3;
nameTooLong = 4;
nameTooShort = 5;
deleteError = 6;
subDirDelete = 7;
bootSetEmpty = 8;
noBuckets = 9;
headerTooShort = 10;
headerKind = 11;
indexError = 12;
nameNotSubDir = 13;
notCallable = 14;
(*$e*)
(* STUB TYPES *)
TYPE
æØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØ
Subjectidentification = fullid;
SPerm = (StubPermit,stubDelete,stubGetRef,
StubWrite,stubReName);
StubPermissions = SET OF Sperm;
FPerm = (filePermit,fileRead,fileWrite,
fileExecute);
Filepermissions = SET OF FPerm;
ØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØå
StubLocRef = ^^Stublocals;
BucketRef = ^^bucketlocals;
StubData = RECORD (* Stub *)
StubName: name16;
MotherIndex: integer; (* index of this Stub in "MotherBucket" *)
END;
InstallMode = (Creating,loading);
ScanData = record
lastI: integer;
end;
ScanLocals = RECORD
code: ref;
data: ^^ScanData;
currBucket: BucketRef;
MotherStub: StubLocRef;
END;
ScanLocRef = ^^ ScanLocals;
(* BUCKETS:
The Stub keeps its name entries in "buckets". Each bucket
contains a number of entries (together with associated
pointers). The bucket size is determined at the Stub's
creation time (the bucket size of the Root Stub is a
constant: "RootsBucketSize").
The buckets are storage segments, each with an envelope
containing the pointers associated with the name entries.
The buckets are organized in an owner set ("Buckets") of
the Stub.
When the buckets run full, the Stub will try to allocate
a new one automatically.
All the bucket entries of a Stub are protected against
concurrently conflicts by the "DirGate". *)
TYPE
BucketEntry = RECORD
Name: name16;
index: integer; (* index of itself! *)
NoProtected: boolean;
kind: Integer;
END;
BucketArray = array Æ1..BucketSizeÅ of BucketEntry;
BucketLocals = RECORD
Entries: ^^ BucketArray;
Ptrs: ARRAY Æ1..bucketsizeÅ OF Ref;
END;
StubLocals = RECORD
code: ref;
BootOwnerSet: ref;
Allocate: ref; (* Simple *)
Scheduler: ref; (* Simple *)
Intscheduler: ref; (* Simple *)
FullSpace: ref; (* Segment mapping of entire physical
address space *)
DefVirt: ref; (* simple *)
Ego: ObjDirRefType; (* refObj *)
EgoEnv: StubLocRef; (* refEnv *)
BootProc: ref;
(* The pointers above are kernel-defined *)
BootPos: BufferRef; (* maintains a position within the BootOwnerSet.
Points to the next segment to be treated *)
(* Pointers to represent the tree-structure of the Stubs *)
RootStub: StubLocRef; (* refEnv *)
MotherStub: StubLocRef; (* refEnv *)
SubStubs: StubLocRef; (* manager set of sub-stubs *)
MotherBucket: BucketRef; (* refEnv to bucket in mother stub *)
(* Pointers to hold the entries under the Stub *)
LocalData: ^^StubData; (* Storage segment *)
Created: ^^; (* manager set of Callable Modules *)
Buckets: BucketRef; (* manager set of bucket envelopment *)
BucketOwners: ^^; (* owner set of buckets *)
newBucketOwner: ^^; (* temporary owner set of new buckets *)
DirGate: ^^Gate; (* Protects insertion and removal of
bucket entries *)
ScanSet: ScanLocRef; (* manager set of Scan object *)
(* Standard objects under the stub *)
æØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØ
Security: ^^SecuritySys; (* refObj *)
IdentObj: ^^Ident;
SysMan: ^^SystemMan;
ØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØå
END; (* StubLocals *)
(*$e*)
function MakeResult ( family, main, aux, argNo: Byte ): resultType;
var r: resultType;
begin
r.family := family;
r.main := main;
r.auxCause := aux;
r.argNo := argNo;
r.orgNo := ObjDirOrg;
r.orgSys := ObjDirSys;
MakeResult := r;
end;
function LastNonBlank ( s: fullId ): integer;
var i: integer;
begin
i := 0;
while (i < elements(s)) and (sÆi+1Å > ' ') do i := i + 1;
LastNonBlank := i;
end;
procedure CopyBytes ( univ source, dest: blockPtr );
var i, max: integer;
begin
max := elements ( source );
if max > elements ( dest ) then max := elements ( dest );
for i := 1 to max do destÆiÅ := sourceÆiÅ;
end;
procedure FillBytes ( univ b: Byte; univ dest: blockPtr );
var i: integer;
begin
for i := 1 to elements ( dest ) do destÆiÅ := b;
end;
function LegalChar ( c: char ): boolean;
begin
legalChar := (c > ' ') and not (c = slash);
end;
function NameOk ( name: shortid ): boolean;
var
i: integer;
ok: boolean;
begin
ok := true;
for i := 1 to LastNonBlank( name ) do begin
ok := ok and LegalChar( nameÆiÅ );
with c = nameÆiÅ do
if ('A'<=c) and (c<='Z') then
c := chr(ord('a')-ord('A')+ord(c));
end;
NameOK := ok;
end; æ NameOk å
PROCEDURE concatNames ( name1: fullid;
name2: fullid;
outname: fullid);
(* returns, "name1" concatenanted with "name2". A slash is
inserted between the names if required, i.e. if "name1"
doesn't end with a slash, and "name2" doesn't login with
a slash. The syntax of the names is not verified.
Abnormal result:
NameTooLong: "name1" and "name2" cannot fit into "outname".
*)
var i, length1, length2, lengthOut, lengthRest: integer;
insertSlash: boolean;
BEGIN
æ#b# PrintText ( ' ConCatNames ');#e#å
length1 := LastNonBlank ( name1 );
length2 := LastNonBlank ( name2 );
lengthOut := elements ( outName );
if (length1 = 0) or (length2 = 0) then
Exception(MakeResult(Universal,-DataValueIllegal,stringTooShort,0));
insertSlash := not ((name1Ælength1Å=slash) or (name2Æ1Å=slash));
if insertSlash then i := 1 else i := 0;
lengthRest := lengthOut-(length1+length2+i);
if lengthRest >= 0 then begin
CopyBytes(name1Æ1..length1Å, outName);
if insertSlash then outNameÆlength1+1Å := slash;
CopyBytes(name2Æ1..length2Å,
outNameÆlength1+1+i..lengthOutÅ);
if lengthRest > 0 then
FillBytes(' ',
outNameÆlength1+1+i+length2..lengthOutÅ);
end else begin
Exception(MakeResult(Universal,-DataValueIllegal,stringTooShort,-1));
end;
æ#b# Printvar ( ' ConcatNames Newname = ' , outname );#e#å
END; (*** concatNames ***)
(*$e*)
PROCEDURE getShortid (VAR name: fullId;
VAR base: integer;
VAR firstShortid: name16);
(* Scans "Name" for the first shortid after index "base"
(i.e. NameÆbase+1..elements(name)Å is scanned).
The "first shortid" is defined as follows:
1: It may be prefixed by a slash.
2: It is syntactically similar to a Pascal identifier
of up to 16 characters.
3: The end-delimiter must be a slash, blanks, or the
physical end of "Name".
At return "base" is updated to point to the last
character of the shortid found, thus being "base" of
the next shortid. *)
VAR i, nameLast: integer;
finish: boolean;
BEGIN
æ#b# PrintText (' Getshortid ');#e#å
nameLast := LastNonBlank( name );
IF nameLast <= base THEN firstShortid := NULL
ELSE BEGIN
IF NameÆbase+1Å = slash THEN base := base+1;
IF base = nameLast THEN
Exception(MakeResult(Universal,-DataValueIllegal,nameMissing,-1));
IF not LegalChar ( nameÆbase+1Å ) THEN
Exception(MakeResult(Universal,-DataValueIllegal,nameError,-1));
i := 1; finish := false;
REPEAT
IF LegalChar ( nameÆbase+1Å ) THEN BEGIN
with c = nameÆbase+1Å do
if ('A'<=c) and (c<='Z') then
firstshortidÆiÅ := chr(ord('a')-ord('A')+ord(c))
else
firstshortidÆiÅ := c;
base := base+1; i := i+1;
END ELSE BEGIN
finish := true;
IF NOT (NameÆbase+1Å = slash) THEN
Exception(MakeResult(Universal,-DataValueIllegal,nameError,-1));
END;
UNTIL (base=nameLast) OR finish or (i>ShortidLength);
IF i > ShortIdLength THEN
Exception(MakeResult(Universal,-DatavalueIllegal,nameTooLong,-1));
IF i < ShortIdLength THEN
FillBytes (' ',firstShortIdÆi..ShortIdLengthÅ);
END;
æ#b#printVar('ShortId = ', firstShortId);#e#å
END; (*** getShortid ***)
(*$e*)
PROGRAM SCANIMPLEMENT OBJECT ITEMSCAN WITH SCANLOCALS;
entry GetInf with record tt: ref; end;
(* out Name: shortid;
OUT kind: Integer *)
VAR
found: boolean;
auxText: shortId;
BEGIN
æ#b# PrintText (' GetInf '); #e#å
WITH data^^ DO BEGIN
Check(motherstub^^.DirGate.Lock);
in
found := false;
while not found do begin
WITH d = currBucket^^.Entries^^ DO BEGIN
WHILE (lastI < bucketSize) AND NOT found DO BEGIN
lastI := lastI+1;
found :=(dÆlastIÅ.kind <> FreeEntry) AND
(dÆlastIÅ.kind <> LockedEntry);
END;
IF found THEN BEGIN
FillBytes(' ',Name);
CopyBytes(dÆlastIÅ.Name, Name);
kind := dÆlastIÅ.kind;
if NextValArg( auxText ) then begin
FillBytes(' ', auxText);
case kind of
loadedProgram : CopyBytes('preloaded program',auxText);
loadedLibrary : CopyBytes('library module',auxText);
generalObject : CopyBytes('general object',auxText);
accessObject : CopyBytes('access object',auxText);
pointerItem : CopyBytes('pointer item',auxText);
subDir : CopyBytes('local directory',auxText);
end;
end; æifå
END; æ IF found å
END; æ WITH å
if not found then begin
StopCheck(NextInSet(MotherStub^^.Buckets,CurrBucket));
lastI := 0;
end;
end; æ while not found å
do æ nothing å;
Check(MotherStub^^.DirGate.Open);
if not found then
ObjReturn(MakeResult(objDirFamily,-ExtRefNotFound,0,0));
end; æ with data^^ å
END; (*** GetInf ***)
otherwise scanOther with record
t1: ref;
end;
begin
Exception(MakeResult(Universal,entryIllegal,0,0) );
end;
END; (***** Scan *****)
æØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØ
(* global *) FUNCTION VerifyOperation (permission: Stubpermissions;
VAR targetStub: StubLocRef;
Name: Shortid): boolean;
(* Verifies that the caller of the Stub system has the
permission "permission" for "Name" in "TargetStub" -
or that "Name" isn't protected *)
VAR SystemId: Subjectidentification;
UserId: Subjectidentification;
result: ResultType;
fullName: fullid;
protected: boolean;
perms: Stubpermissions;
BEGIN
PrintText (' VerifyOperation ');
VerifyOperation:= true;
IF SameEntity(TargetStub^^.Security , VOID) THEN VerifyOperation:=true
ELSE
BEGIN
VerifyOperation := false;
Result := TargetStub^^.Allocate.GetId (1, SystemId,UserId);
WITH d = TargetStub^^.LocalData^^ DO
concatNames (result, d.StubName, Name, fullName);
Result := TargetStub^^.Security.VerifyItem (systemId,
UserId, perms,fullname);
IF (Result.main = ok) AND
(permission IN perms OR NOT protected) THEN
VerifyOperations := true;
END;
END; (*** VerifyOperations ***)
ØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØå
(*$e*)
FUNCTION LookUpEntry (VAR TargetStub: StubLocRef;
VAR Name: name16;
VAR Bucket: BucketRef;
VAR entryNo: BucketEntry): boolean;
(* Search for "Name" in TargetStub". If an entry is found,
it is locked, and the specifications: "Bucket" and
"entry" are returned. If no entry is found, "LockEntry"
returns "false". *)
VAR
found: boolean;
i: integer;
BEGIN
æ#b# PrintText (' LookUpntry ');#e#å
found := false;
in
StopCheck ( FirstInSet (TargetStub^^.Buckets ,bucket) );
REPEAT
WITH d = Bucket^^.Entries^^ DO
BEGIN
i := 0;
REPEAT
i := i+1;
found := (dÆiÅ.Name = Name)
AND (dÆiÅ.kind <> FreeEntry)
AND (dÆiÅ.kind <> LockedEntry);
UNTIL found OR (i = bucketSize);
IF found THEN
BEGIN
entryNo := dÆiÅ;
END;
END;
IF NOT found THEN StopCheck ( NextInSet (TargetStub^^.Buckets,
bucket) );
UNTIL found;
do æ nothing å;
LookUpEntry := found;
END; (*** LockEntry ***)
(*$e*)
FUNCTION lookup (VAR Targetstub: StubLocref;
Name: name16;
VAR Bucket: BucketRef;
VAR entryNo: BucketEntry;
VAR ObjRef: ref): boolean;
(* Searches for "Name" in the specified Stub ("TargetStub")
Returns the corresponding entry and pointer. The pointer
(ObjRef") is a refObj, except when referring to a Stub
in which case an envelope reference is returned. If a
Loaded Module is referred to, a pointer to the first
Storage segment of the owner set is returned in "ObjRef".
If no entry is found, "lookup" returns false.
The parameter "Bucket" returns an envelope reference
to the bucket in which the entry was found. This reference
is used to handle Loaded Modules (i.e. inspecting the
owner set of such), only. *)
BEGIN
æ#b# PrintText (' Lookup ');#e#å
Check ( TargetStub^^.DirGate.Lock );
in
IF LookUpEntry (TargetStub, Name, Bucket, entryNo) THEN
BEGIN
CASE entryNo.kind OF
generalObject,loadedLibrary,accessObject,pointerItem,subDir :
Check ( Copy ( Bucket^^.PtrsÆentryNo.indexÅ,ObjRef) );
loadedProgram:
Check ( FirstInSet (Bucket^^.PtrsÆentryNo.indexÅ,ObjRef) );
END;
lookup := true;
END ELSE
lookup := false;
Check ( TargetStub^^.DirGate.open );
do begin
Check ( TargetStub^^.DirGate.open );
Exception ( GetException );
end;
END; (*** lookup ***)
(*$e*)
FUNCTION OccupyFree (VAR TargetStub: StubLocref;
VAR NewName: name16;
VAR Bucket: BucketRef;
VAR index: integer): boolean;
(* Finds a free bucket entryNo in the indicated Stub, and
marks it as "locked". "NewName" MAY be used to guide
the selection of a free entryNo, thereby optimizing later
searches for the name. The entryNo found is specified by
"bucket" and "index" on return.
If these is no room left for the new entryNo "OccupyFree"
will try to allocate a new bucket, but if that fails,
it will return "false" *)
VAR
found: boolean;
size: SizeType;
i: integer;
BEGIN
æ#b# PrintText (' OccupyFree ');#e#å
Found := false;
Check ( TargetStub^^.DirGate.Lock );
in
StopCheck ( FirstInSet (TargetStub^^.Buckets, Bucket) );
REPEAT
WITH d = Bucket^^.Entries^^ DO BEGIN
index := 1;
WHILE (index < bucketSize) AND
(dÆindexÅ.kind <> FreeEntry) DO index:=index+1;
found := dÆindexÅ.kind = FreeEntry;
IF found THEN dÆindexÅ.kind := LockedEntry;
END;
IF NOT found THEN StopCheck(NextInSet (TargetStub^^.Buckets, Bucket) );
UNTIL found;
do ænothingå ;
Check ( TargetStub^^.DirGate.open );
if not found then begin æ add new bucket å
NoCheck(ClearSize ( size ));
NoCheck(AddEnv ( size, refs ( bucketLocals ) ));
NoCheck(AddEmbSeg ( size, bytes ( bucketArray ) ));
in
Check ( targetStub^^.allocate.NewObj ( out targetStub^^.newBucketOwner;
size, i ) );
Check ( targetStub^^.DirGate.Lock );
in
Check ( MoveOwn ( targetStub^^.newBucketOwner,
targetStub^^.bucketOwners ) );
with targetStub^^ do
Check ( DeclEnv ( bucketOwners, buckets, bucket,
refs(bucketLocals), 0, makeSize(0,0),
makeSize(-1,-1) ) );
Check ( NewSeg ( bucket^^.entries, bytes(bucketArray) ) );
with d = bucket^^.entries^^ do begin
for i := 1 to bucketSize do with dÆiÅ do begin
index := i;
kind := freeEntry;
end;
index := 1;
dÆ1Å.kind := lockedEntry;
end;
found := true;
do æ nothing å;
Check ( targetStub^^.dirGate.open );
do æ nothing å;
end;
OccupyFree := found;
END; (*** OccupyFree ***)
(*$e*)
PROCEDURE CleanUpEntry (VAR TargetStub: StubLocref;
VAR bucket: Bucketref;
index: integer;
kind: Integer);
(* Frees an already locked entryNo and deletes its
associated object(s) *)
var
res: resultType;
BEGIN
æ#b# PrintText (' CleanUpEntry ');#e#å
in
repeat
res := ( Dealloc ( bucket^^.PtrsÆindexÅ,
bucket^^.PtrsÆindexÅ ) );
StopCheck( res );
until false;
do æ nothing å;
in
Check ( Copy ( Void, bucket^^.PtrsÆindexÅ ) );
do Exception ( res );
Check ( TargetStub^^.DirGate.lock );
WITH d = bucket^^.Entries^^ DO
dÆindexÅ.kind := FreeEntry;
Check ( TargetStub^^.DirGate.open );
END; (*** CleanUpEntry ***)
(*$e*)
PROCEDURE GetRefSimple (VAR StartStub: StubLocref;
VAR Name: name16;
FullName: fullid;
VAR Bucket: Bucketref;
VAR entryNo: BucketEntry;
VAR ObjRef: ref
VAR stub: stubLocRef );
(* Searches (algol-like in scope) upwards from "StartStub" for
the simple shortid "Name", and returns the corresponding
entryNo and pointer (in case of a substub: an envelope
pointer, though). The parameter BucketRef returns an
envelope pointer to the Bucket in which the entryNo were
found (BucketRef is only used when handling the owner
sets of Loaded Modules).
The complete fullid of the entryNo is returned in "FullName".
*)
VAR
found: boolean;
BEGIN
æ#b# PrintText (' GetRefSimple ');#e#å
Check ( Copy ( startStub, stub ) );
repeat
found := lookUp ( stub, name, bucket, entryNo, objRef );
if not found then begin
check ( copy ( stub^^.motherStub, stub ) );
end;
until found or SameEntity ( Void, stub );
if found then begin
with d = stub^^.localdata^^ do
concatNames ( d.stubName, name, fullName );
end else begin
exception(MakeResult(objDirFamily,-ExtRefNotFound, 0, 0 ) );
end;
END; (*** GetRefSimple **)
PROCEDURE GetRefComplete (VAR RootStub: StubLocref;
VAR Name: fullid; (* complete *)
VAR used: integer;
VAR targetStub: stubLocRef;
VAR Bucket: Bucketref;
VAR entryNo: BucketEntry;
VAR ObjRef: ref);
(* Scans a complete fullid and returns the corresponding
entryNo and pointer (in case of a substub: an envelope
pointer). The parameter BucketRef returns an
envelope pointer to the Bucket in which the entryNo were
found (BucketRef is only used when handling the owner
sets of Loaded Modules). *)
VAR base: integer;
sid: name16;
finish: boolean;
BEGIN
æ#b# PrintText (' GetRefComplete ');#e#å
Check( Copy (RootStub, targetStub) );
finish := false;
base := 0;
REPEAT
getShortid ( Name,base, sid);
IF sid <> NULL THEN
BEGIN
IF lookup (targetStub, sid, bucket, entryNo, ObjRef) THEN
BEGIN
used := base;
finish := entryNo.kind <> subDir;
if not finish then
Check(Copy(ObjRef,TargetStub) );
END else begin
Exception(MakeResult(objDirFamily,-ExtRefNotFound, 0, 0 ) );
end;
END else
finish := true;
UNTIL finish;
END; (*** GetRefComplete ***)
(*$e*)
PROCEDURE GlobalInsertPtr (VAR TargetStub: StubLocref;
Name: name16;
VAR Ptr: ref;
NoProtect: boolean
var bucket: bucketRef );
(* Inserts a simple pointer in "TargetStub") *)
VAR
index: integer;
fullNewName: nameMax;
BEGIN
æ#b# PrintText (' GlobalInsertPtr ');#e#å
IF NOT OccupyFree (TargetStub, Name, bucket, index) THEN
Exception( MakeResult( Universal,-NoResources,0,0) );
æØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØ
(* Create a security item for the pointer *)
IF NOT SameEntity(TargetStub^^.Security , VOID) OR NotProtected THEN
BEGIN
permission := ÆStubPermit,StubDelete,StubGetRef,StubReNameÅ;
WITH d = TargetStub^^.LocalData^^ DO
concatNames (Result, d.StubName, Name, fullNewName);
IF Result.main <> ok THEN GOTO exit (* NameTooLong *);
RESULT := TargetStub^^.Allocate.GetId(1,SystemId,UserId);
IF Result.main <> ok THEN
GOTO exitlabel;
RESULT := TargetStub^^.Security.CreateItem (SystemId,UserId,
permission,fullnewname);
IF Result.main <> ok THEN
GOTO exitlabel;
END;
ØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØå
(* initialization bucket entryNo and make it public *)
Check ( Copy (Ptr, bucket^^.PtrsÆindexÅ) );
WITH d = bucket^^.Entries^^ DO
BEGIN
WITH e = dÆindexÅ DO
BEGIN
FillBytes ( ' ',e.name );
CopyBytes ( name, e.name );
e.Index := index;
e.NoProtect := NoProtect;
Check ( TargetStub^^.DirGate.Lock );
e.Kind := pointerItem;
Check ( TargetStub^^.DirGate.open );
END;
END;
END; (*** GlobalInsertPtr ***)
(*$e*)
PROCEDURE GlobalGetRef (VAR ThisStub: StubLocref;
name: fullid; (* complete or simple *)
VAR used: integer;
VAR ObjectRef: ref; (* may be subsegment
owner on return *)
VAR Kind: integer;
VAR refp: ref;
VAR bucket: bucketRef;
VAR workRef1: ref );
(* Returns a simple pointer to a Callable Module, an Access
Object, or a SubStub; a copy of a SimplePtr; or a subsegment
pointer to a Library Module. It is checked that the
"RequesterSubjId" is GetRef-permitted to the entity, or
that the entity is NoProtect.
*)
VAR
entryNo: BucketEntry;
sid: name16;
fullName: nameMax;
protected: boolean;
size: SizeType;
i: integer;
BEGIN
æ#b# PrintText (' GlobalGetRef ');#e#å
IF nameÆ1Å = slash THEN BEGIN
GetRefComplete (ThisStub^^.RootStub,name,used,
workRef1,bucket,entryNo,refp);
END ELSE BEGIN
used := 0;
getShortid ( name, used, sid);
GetRefSimple (ThisStub, sid, fullName, bucket,
entryNo, refp, workRef1 );
END;
æ#b#printVar ( 'Entry = ', entryNo );#e#å
IF entryNo.kind = loadedProgram THEN
Exception(MakeResult(objDirFamily,-ExtRefProtected,0,0) );
æØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØ
permission := ÆÅ;
IF NOT entryNo.NoProtected THEN
IF SameEntity(ThisStub^^.Security , VOID) THEN
permission := ÆStubGetRefÅ
ELSE
RESULT := ThisStub^^.Security.VerifyItem (SystemId,UserId,permissions,
fullname);
IF NoProtected OR (stubGetRef IN permission) THEN
BEGIN
ØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØå
Kind := entryNo.kind;
CASE kind OF
generalObject, accessObject, pointerItem :
Check( Copy (refp, ObjectRef) );
subDir :
Check( Copy (refp:stubLocRef^^.Ego, ObjectRef) );
loadedLibrary :
BEGIN (* create subsegment with "execute" capability only *)
NoCheck( ClearSize (size));
NoCheck( AddSub (size));
Check ( ThisStub^^.Allocate.NewObj(out ObjectRef;
size, i ) );
Check ( DeclSub (ObjectRef, var program refp:bufferRef^^) );
END; æ!!!!!!!!!! pot. kernel problem !^^^^^^^^^^^^^^^ å
END; (*case*)
æØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØ
END ELSE
SetResult (Result, Rejected, ExtRefProtected,
objDirFamily, 0, refp);
ØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØå
END; (*** GlobalGetRef ***)
(*$e*)
PROCEDURE GlobalDelete (VAR TargetStub: StubLocref;
Name: name16;
VAR bucket: bucketRef );
(* Deletes a bucket entryNo (not SubStub) in "TargetStub" *)
VAR
entryNo: BucketEntry;
BEGIN
æ#b# PrintText (' GlobalDelete ');#e#å
Check( targetStub^^.Dirgate.Lock );
in
IF LookUpEntry (TargetStub, Name, bucket, entryNo) THEN BEGIN
IF entryNo.kind = subDir THEN
Exception(MakeResult(Universal,-EntryIllegal,SubDirDelete,0) );
with d = bucket^^.entries^^ do
dÆentryNo.indexÅ.kind := lockedEntry;
Check( targetStub^^.DirGate.open );
in
CleanUpEntry (TargetStub,bucket,entryNo.index,entryNo.kind);
do begin
Check ( targetStub^^.DirGate.Lock );
Exception ( GetException );
end;
END ELSE BEGIN
Exception(MakeResult(objDirFamily,-ExtRefNotFound, 0,0) );
END;
do begin
Check ( targetStub^^.DirGate.open );
Exception ( GetException );
end;
END; (*** GlobalDelete ***)
(*$e*)
æ----------------------- Install ---------------------------å
type
refArray = array Æ1..wordMaxÅ of ref;
installTemps = record
workRef1, workRef2,workRef3: ref;
segm: bufferRef;
bucket, targetBucket, loadBucket: bucketRef;
loadPos: bufferRef;
env: ^^refArray;
auxBootPos: ref;
faoObj: faoRefType;
refHeader: bufferRef;
rootStub: stubLocRef;
end;
PROCEDURE Install
(VAR ThisStub: StubLocref;
callMode: InstallMode;
VAR Name: name16;
SourceName: fullid;
SourceAddr: Address;
NewSubject: boolean;
NoProtect: boolean;
VAR Obj: ref;
VAR temps: installTemps);
(* Creates or loads (depending on "callMode") an Installation
Module.
OVERVIEW OF PROCEDURE:
Introduction: Various preparations
1. Decide the exact source of the Installation Module and
get caller's security item for that.
2. Get the (subject) id, authorizing the creation of a new
subject identification.
3. Get the first part of the Installation Module Header.
4. Find free bucket entryNo.
5. Depending on callMode:
creating: 5c.1: Compute size of general object
5c.2: Create general object
5c.3: Insert subject identification
5c.4: Initialize local pointers
loading: 5l: Create and initialize Header Segment
(if not Library Module).
6. Create and initialize local data segments
7. Create security item. Make entryNo public. Verify the return
of a pointer in "Obj".
ExitPart: Clean-up after errors, i.e. reestablish the
situation as it were prior to the call of Install.
*)
(* CONSTANTS *)
const
programModule = 0; libraryModule = 1;
(* value of "kind"-field in Installation Module Header *)
reentrant = 1;
(* TEMPORARY VARIABLES *)
(* auxiliary.
(no information is carried from one part to the next in
any of these variables) *)
VAR entryNokind: Integer;
used,
pos,
auxpos,
i, j: integer;
sBeg, sEnd: integer;
size: SizeType;
sid: name16;
entryNo: BucketEntry;
sourceProtected: boolean;
res: resultType;
(* variables used to specify the exact source and its
attributes= *)
loadMode: (fromFile,fromLoaded,fromBoot,fromROM);
LocalName: nameMax;
nameLength: integer;
(* CASE localMode OF
fromFile: complete LocalName of file
fromLoaded: complete name of Loaded Module
otherwise irrelevant *)
(* following variables are relevant only for loadMode = fromFile *)
æØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØ
FSSystemId: fullid;
(* complete name of file system in which the source
originates, concatenated with the security class of
the file system: <filesys name>/<class> *)
filePerms: Fpermissions;
(* caller's security item for the load file *)
ØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØå
(* following variables are relevant only for loadMode = fromLoaded *)
loadEntry: BucketEntry; (* entryNo of Loaded Module *)
æØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØ
loadPerms: StubPermissions;
(* caller's security item for the Loaded Module *)
(* Other Security variables *)
SystemId,
AuthorizingId: SubjectIdentification;
permissions: StubPermissions;
(* the creator's security item for the new object *)
ØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØå
(* variables used to specify the target entryNo *)
TargetIndex: integer; (* index in "TargetBucket" *)
fullObjName: nameMax;
(* complete name of new entryNo *)
(* variables used to hold Header Segment or parts hereof during
load *)
const
blockLength = 256;
var
firstHBlock: record
size: word;
rest: array Æ3..blocklengthÅ of byte;
end;
headerPos: integer;
(* the last byte retrieved from the refHeader^^-array *)
(* following records reflect the static portions of the
Installation Module format: *)
HPrefix: HeaderPrefix;
loadSectDescr: LdSctDescr;
locSegmDescr: LocDatSegmDescr;
modificationDescr: ModifDescr;
objectRefDescr: ObjRefDescr;
procedure GetNextRec ( var pos: integer; univ rec: bufPtr );
begin with temps do begin
with d = refHeader^^ do begin
copyBytes(dÆpos..elements(d)-1Å, rec);
æ#b# PrintVar (' GetNextRec Rec: ', rec );#e#å
pos := pos + elements(rec);
if pos > elements(d) then
Exception(MakeResult(objDirFamily,
-HeaderFormatError,headerTooShort,0));
end;
end; æ with temps å
end; æ GetNextRec å
procedure CheckIndex ( i: integer );
begin
if (i<1) or (i>hPrefix.NoLocPtrs) then
Exception(MakeResult(objDirFamily,HeaderFormatError,indexError,0));
end;
(* Install, Introduction *)
(* Various preparations *)
BEGIN with temps do begin
Check ( Copy (ThisStub^^.RootStub,RootStub) ); (* often used *)
æØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØ
IF callMode = loading THEN BEGIN
ØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØå
NewSubject := false; (* just to be sure *)
NoProtect := true; (* just to be sure *)
æØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØ
END;
ØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØå
æ#b#PrintText (' Install part 1 ');#e#å
(* Install, part 1 *)
(* Decide the exact source of the Installation Module and get
caller's security item for it *)
fillBytes(' ', localName);
nameLength := LastNonBlank(sourceName);
IF nameLength <> 0 THEN
BEGIN
æ#b# PrintVar (' SourceName ', sourceNameÆ1..nameLengthÅ );#e#å
in
used := 0;
IF SourceNameÆ1Å = slash THEN BEGIN
GetRefComplete (ThisStub^^.RootStub,SourceName,used,
workRef1,loadBucket,loadEntry,loadPos);
END ELSE BEGIN
getShortid (SourceName,used,sid);
GetRefSimple (ThisStub,sid,LocalName,
loadBucket,loadEntry,loadPos,workRef1 );
END; (* simple name *)
do begin
res := getException;
if (res.orgSys=ObjDirSys) and
(res.orgNo =ObjDirOrg) then
res.argNo := -2;
Exception ( res );
end;
IF used < nameLength THEN BEGIN
(* must be a file *)
æ#b# PrintText (' Source is a file ');#e#å
if loadEntry.kind in ÆloadedProgram, loadedLibrary, subDirÅ then
Exception(MakeResult(objDirFamily,-SourceNotFound,notCallable,-2));
if sourceNameÆused+1Å = slash then used := used + 1;
StopCheck (loadPos.ASSIGN (out faoObj;SourceNameÆused+1..nameLengthÅ,
readRight, OldFile ) );
loadMode := fromFile;
CopyBytes(SourceNameÆused+1..nameLengthÅ,localName);
END ELSE BEGIN
(* must be a Loaded Module *)
æ#b# PrintText (' source is a loaded module ');#e#å
loadMode := fromLoaded;
IF (loadEntry.kind <> loadedProgram) OR (callMode = loading) THEN
Exception(MakeResult(objDirFamily,-SourceNotFound,0,-2) );
CopyBytes (SourceName, localName);
END;
END ELSE BEGIN
(* SourceName = NULL *)
æ#b# PrintText (' source is empty ');#e#å
IF SourceAddr = 0 THEN loadMode := fromBoot
ELSE loadMode := fromROM;
END;
(* Now "loadMode" specifies the type of source, and depending on
that, the following variables specify the exact source:
fromFile: "faoObj"
fromLoaded: "loadBucket","loadEntry","loadPos"
fromBoot: given by root stub's local pointers ("BootOwnerSet" and
"BootPos")
fromROM: ?
"LocalName" specifies either the complete LocalName of the
load FILE or the complete (stub-) name of the LOADED Module *)
(* Get the caller's security item for the source. If "NoProtect"
is specified by the caller, check if it is legal *)
æØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØ
IF NOT SameEntity(ThisStub^^.Security , VOID) THEN
BEGIN
Result := ThisStub^^.Allocate.GetId (1,SystemId,UserId);
IF Result.main <> ok THEN GOTO foreignexit;
CASE loadMode OF
fromFile:
BEGIN
(* Get file system's SystemId *)
Result := ThisStub^^.Allocate.GetObjIdent (faoObj,subjectId);
IF Result.main <> ok THEN GOTO foreignexit;
FSSystemId := subjectId.SystemId;
Result := ThisStub^^.Security.VerifyItem (SystemId,UserId,
filePerms,
localname);
IF Result.main <> ok THEN GOTO foreignexit;
END;
fromLoaded:
BEGIN
IF loadEntry.NoProtect THEN sourceProtected := false
ELSE
BEGIN
Result := ThisStub^^.Security.Verifyitem (SystemId,UserId,
loadPerms,
localname);
IF Result.main <> ok THEN GOTO foreignexit;
END;
fromBoot,
fromROM:
sourceProtected := false
END; (* case *)
(* Check the validity of "NoProtect" *)
IF NoProtect AND sourceProtected THEN
BEGIN
SetResult (Result, Rejected, ExtRefProtected, objDirFamily,0
LoadMode);
GOTO exitlabel;
END;
END;
(* "filePerms" or "loadPerms" are now defined (if "NoProtect" isn't set)
"CallersSubjtId" is defined
"FSSystemId" is defined if loadMode = fromFile *)
(* INSTALL, PART 2 *)
(* Get the id authorizing the creation of a new object
identification (only "NewSubject" is set)
The id consists of the following:
fromfile: (FSSystemid/LocalName, caller's userid, caller's termid);
fromLoaded: (LocalName , --"-- , --"-- );
fromBoot: (NULL , --"-- , --"-- );
fromROM: , --"-- , --"-- );
*)
if NewSubject AND (NOT RefEqal(ThisStub^^.Security, void)) THEN
BEGIN
AuthorizingId := SystemId;
CASE loadMode OF
fromFile:
concatNames (Result,FSSystemId,LocalName,
AuthorizingId.SystemId);
fromLoaded:
AuthorizingId.SystemId := LocalName;
fromBoot,
fromROM: AuthorizingId.SystemId := NULL;
END; (* case *)
END;
(* Now "AuthorizingId" is defined "NewSubject" is set *)
ØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØå
(*$e*)
(* INSTALL, PART 3 *)
æ#b#PrintText (' install part 3 ');#e#å
(* Get the first of the Installation Module Header
(the "Header Prefix") *)
CASE loadMode OF
fromFile:
BEGIN
æ#b# PrintText (' loadmode = fromfile ');#e#å
Check( faoObj.ReadSeq(var in out firstHBlock; out used ) );
Check( NewSeg(refHeader, firstHBlock.size) );
with h = refHeader^^ do begin
copyBytes(firstHblock, h);
if firstHblock.size > used then begin
Check(faoObj.ReadSeq(var in out hÆused..firstHBlock.size-1Å;
out used ) );
end;
end;
END;
fromLoaded:
BEGIN
(* Note: The indivisibility of the following on the Loaded
Module's owner set is implicity ensured by the
simple pointer "loadPos", i.e. if the Loaded
Module is deleted during the operations, "loadPos"
will go NIL (VOID), and the result-code
"SourcePreempted" is generated *)
æ#b# PrintText (' loadmode = fromloaded ');#e#å
Check( Copy (loadPos, refHeader) );
Check( NextInSet (loadBucket^^.PtrsÆloadEntry.IndexÅ,loadpos) );
END;
fromBoot:
BEGIN
æ#b# PrintText (' loadmode = fromboot ');#e#å
if SameEntity (RootStub^^.BootPos, Void) then
Exception(MakeResult(objDirFamily,-SourceNotFound,BootSetEmpty,0));
in
StopCheck( Copy (RootStub^^.BootPos, refHeader) );
StopCheck( NextInSet(RootStub^^.BootOwnerSet,RootStub^^.BootPos) );
do Exception(MakeResult(objDirFamily,-SourceNotFound,BootSetEmpty,0));
END;
(* fromROM:
not implemented *)
END; (* case *)
headerPos := 0;
GetNextRec ( headerPos, hPrefix );
IF (hPrefix.kind = libraryModule) AND (callMode = creating) THEN
Exception(MakeResult(objDirFamily,-HeaderFormatError,HeaderKind, 0) );
IF Name = NULL THEN Name := hPrefix.objectname; (* default *)
if not nameOk(name) then
Exception(MakeResult(objDirFamily,-HeaderFormatError,NameError, 0));
IF lookup (ThisStub,Name,bucket,entryNo,bucket (* dummy *)) THEN
Exception(MakeResult(objDirFamily,-ObjectNameExists, 0, 0) );
WITH d = ThisStub^^.LocalData^^ DO
concatNames ( d.StubName, Name, fullObjName);
(* Now "hPrefix" contains the first "record" of the header.
"refHeader" points to a storage segment containing the header,
and "headerpos" specifies the last byte of the header prefix
(i.e. it is base for the next "record").
"Name" is defined and contains the new local name of the module
we are producing. "fullObjName" is the corresponding complete
name *)
(*$e*)
(* INSTALL, PART 4 *)
(* Find free bucket entryNo in this Stub, and mark it as "locked"
until further *)
æ#b#PrintText (' Install part 4 ');#e#å
IF NOT OccupyFree (ThisStub, Name, TargetBucket, TargetIndex) THEN
Exception(MakeResult(Universal,-NoResources, NoBuckets,0) );
WITH d = TargetBucket^^.Entries^^, e = d ÆTargetIndexÅ DO
BEGIN
e.Name := Name;
e.Index := TargetIndex;
e.NoProtect := NoProtect;
(* e.kind is not touched: it is "LockedEntry" until
- further *)
END;
(*$e*)
in æ the remaining part of install å
(* INSTALL, PART 5 *)
(* The action of this part depends on the callMode:
CREATING:
5c.1: Compute the size of the general object to be created.
5c.2: Create the general object
5c.3: Insert Subject Identification
5c.4: Initialize local pointers.
LOADING:
5l: If not loading a Library Module, create and initialize
the Header Segment of the future Loaded Module.
*)
CASE callMode OF
creating:
BEGIN
æ#b# PrintText (' CallMode = Creating ');#e#å
(*** 5c.1: Compute size of general object ***)
NoCheck(ClearSize (size));
(* Add the sizes of the local data segments *)
pos := hPrefix.addFirstLocDatSegmDescr +
hPrefix.addressProgObjDescrs;
FOR i := 1 TO hPrefix.noLocDatSegms DO
BEGIN
auxpos := pos;
getNextRec (auxpos,locSegmDescr);
CASE loadMode OF
fromFile: NoCheck(AddEmbSeg(size,locSegmDescr.sizeOfSegm));
fromLoaded: IF locSegmDescr.Options <> Reentrant
THEN
NoCheck(AddEmbSeg (size,locSegmDescr.sizeOfSegm))
ELSE
NoCheck(AddEmbSub (size));
fromBoot: (* current implementation:
the BootFormat must be expanded *)
IF locSegmDescr.noLoadSections = 0 THEN
(* This is a non-initialized data segment
which is not represented in the
Boot Owner Set *)
NoCheck(AddEmbSeg (size,locSegmDescr.sizeOfSegm));
(* fromROM: not implemented *)
END; (* case *)
pos := pos + locSegmDescr.size;
END; (* for *)
(* Add the object and the envelope size *)
NoCheck(AddGen (size,hPrefix.noLocPtrs));
æ#b# PrintVar (' Size = ',size );#e#å
(*** 5c.2: Create the general object ***)
Check( ThisStub^^.Allocate.NewObj
(TargetBucket^^.ptrs ÆTargetIndexÅ;size,OUT i) );
Check( DeclGen (TargetBucket^^.PtrsÆTargetIndexÅ,
ThisStub^^.Created,Env,hPrefix.noLocPtrs,0,
makeSize(0,0),makeSize(-1,-1),
hPrefix.noTempPtrs,
hprefix.sizeTempData,0,
hPrefix.entryAddress,
hPrefix.callStack, true) );
æØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØ
(*** 5c.3: Insert Subject Identification ***)
IF NOT SameEntity(ThisStub^^.Security , VOID) THEN
IF NewSubject THEN
BEGIN
(* Check that "AuthorizingId" may create a new
subject with system name = "Name" *)
Result := ThisStub^^.SystMan.VerifyItem ( Name,
OUT sid (* class *), AuthorizingId);
IF Result.main <> ok THEN GOTO foreignexit;
(* produce the new subject identification *)
concatNames (Result,Name,sid,SubjectId.SystemId);
(* ignore Result *)
SubjectId.UserId := NULL;
SubjectId.TermId := NULL;
(* Attach it to the general object *)
Result:= ThisStub^^.IdentObj.SetSystemId (
TargetBucket^^.Ptrs ÆTargetIndexÅ,
SubjectId.SystemId);
IF result.main <> ok THEN GOTO foreignexit;
END ELSE
BEGIN
WITH SubjectId DO
BEGIN
SystemId := NULL;
UserId := NULL;
TermId := NULL;
END;
END;
(* Now "SubjectId" contains the verified subject identification
of the new general object *)
ØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØå
(*** 5c.4: Initialize local pointers ***)
FOR i := 1 TO hPrefix.noObjectRefs DO
BEGIN
getNextRec (headerpos,objectRefDescr);
CheckIndex(objectRefDescr.LocPtrIndex);
if objectRefDescr.name = egoObjName then
Check( Copy(targetBucket^^.PtrsÆtargetIndexÅ,
env^^ÆobjectRefDescr.locPtrIndexÅ ) )
else if objectRefDescr.name = egoEnvName then
Check( Copy(env, env^^ÆobjectRefDescr.locPtrIndexÅ ) )
else begin
GlobalGetRef (ThisStub,
objectRefDescr.Name,used,
env^^ÆobjectRefDescr.locPtrIndexÅ, entryNoKind,
workRef1,workRef2,workRef3 );
end;
END;
END; (*creating *)
loading:
BEGIN
(*** 5l: Create and initialize Header Segment if not
Library ***)
æ#b# PrintText (' CallMode = Loading ');#e#å
IF hPrefix.kind = programModule THEN
BEGIN
WITH t = TargetBucket^^.PtrsÆTargetIndexÅ DO
BEGIN
NoCheck(ClearSize(size));
NoCheck(AddSeg(size, hPrefix.size));
Check( ThisStub^^.Allocate.NewObj (out t;
size,OUT i ) );
Check( DeclSeg ( t, hPrefix.size) );
with d = t:bufferRef^^ do begin
pos := 0;
GetNextRec ( pos, d );
end;
END;
END;
END; (* loading *)
END; (* case *)
(*$e*)
(* INSTALL, PART 6 *)
æ#b#PrintText (' Install part 6 ');#e#å
(* Create and initialize the local data segments *)
headerpos := hPrefix.addFirstLocDatSegmDescr +
hPrefix.addressProgObjDescrs;
FOR i := 1 TO hPrefix.noLocDatSegms DO
BEGIN
auxpos := headerpos;
getNextRec (auxpos,locSegmdescr);
CheckIndex(locSegmDescr.LocPtrIndex);
(* create any storage segment necessary *)
CASE callMode OF
creating:
BEGIN
æ#b#PrintText (' Create storage segment callmode = creating ');#e#å
case loadMode of
fromFile: begin
Check( NewSeg (Env^^ÆlocSegmDescr.locPtrIndexÅ,
locSegmDescr.sizeOfSegm) );
Check( Copy (Env^^ÆlocSegmDescr.locPtrIndexÅ, segm) );
end;
fromLoaded: begin
if locSegmDescr.Options = reentrant then begin
Check( NewSub (Env^^ÆlocSegmDescr.locPtrIndexÅ,
var program loadPos^^Æ0..locSegmDescr.sizeOfSegm-1Å));
Check( Copy (Env^^ÆlocSegmDescr.locPtrIndexÅ, segm) );
end else begin
Check( NewSeg (Env^^ÆlocSegmDescr.locPtrIndexÅ,
locSegmDescr.sizeOfSegm) );
Check( Copy (Env^^ÆlocSegmDescr.locPtrIndexÅ, segm) );
end;
end;
fromBoot: begin
if locSegmDescr.noLoadSections = 0 then begin
Check( NewSeg (Env^^ÆlocSegmDescr.locPtrIndexÅ,
locSegmDescr.sizeOfSegm) );
Check( Copy (Env^^ÆlocSegmDescr.locPtrIndexÅ, segm) );
end;
end;
end; æ case å
END;
loading:
BEGIN
æ#b#PrintText (' create storage segment callmode = loading ');#e#å
IF locSegmDescr.noLoadSections > 0 THEN
BEGIN
NoCheck(ClearSize(size));
NoCheck(AddSeg(size, locSegmDescr.sizeOfSegm));
Check( ThisStub^^.Allocate.NewObj
(out TargetBucket^^.PtrsÆTargetIndexÅ;
Size, i ) );
Check( DeclSeg (TargetBucket^^.PtrsÆTargetIndexÅ,
locSegmDescr.sizeOfSegm) );
Check( Copy (TargetBucket^^.PtrsÆTargetIndexÅ,segm) );
END;
END;
END; (* case callMode *)
(* initialize the segment *)
CASE loadMode OF
fromFile:
BEGIN
æ#b#PrintText (' LoadMode = FromFile ');#e#å
FOR j := 1 TO locSegmDescr.noLoadSections DO
BEGIN
(* insert load section *)
getNextRec (auxpos,loadSectDescr);
(* assumptions for the current version:
1. Load Sections are inserted aligned at block
boundaries i.e. relStartAddr MOD 256 = 0, and
length mod 256 = 0
2. Load Sections are found aligned at block
boundaries in the Installation Module:
i.e. addrOfContents MOD 256 = 0. *)
sBeg := loadSectDescr.relStartAddr;
sEnd := loadSectDescr.relStartAddr+loadSectDescr.length-1;
Check(faoObj.ReadSeq(var in out segm^^ÆsBeg..sEndÅ;
OUT used) );
æ!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
Check(faoObj.ReadSeq(var in out segm^^ÆloadSectDescr.relStartAddr
..loadSectDescr.relStartAddr+
loadSectDescr.length -1Å;
OUT used) );
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!å
END;
END; (* fromFile *)
fromLoaded:
BEGIN
æ#b#PrintText (' LoadMode = fromloaded ');#e#å
IF NOT (locSegmDescr.noLoadSections = 0) THEN
BEGIN
IF NOT (locSegmDescr.Options = Reentrant) THEN
with s = segm^^, t = loadPos^^ do
CopyBytes ( t, s );
NoCheck( NextInSet (loadBucket^^.PtrsÆloadEntry.indexÅ,
loadpos) );
END;
END; (* fromLoaded *)
fromBoot:
BEGIN
CASE callMode OF
creating: BEGIN
æ#b#PrintText (' loadmode = fromboot, callmode = creating ');#e#å
IF locSegmDescr.noLoadSections > 0 THEN
BEGIN (* copy boot pointer *)
if SameEntity (RootStub^^.BootPos, Void) then
Exception(MakeResult(objDirFamily,
HeaderFormatError,BootSetEmpty,0));
Check( Copy (RootStub^^.BootPos,
Env^^ÆlocSegmDescr.locPtrIndexÅ) );
NoCheck( NextInSet (RootStub^^.BootOwnerSet,
RootStub^^.BootPos) );
END;
END;
Loading:
BEGIN
æ#b#PrintText (' loadmode = fromboot, callmode = loading ');#e#å
if locSegmDescr.noLoadSections > 0 then begin
if SameEntity (RootStub^^.BootPos, Void) then
Exception(MakeResult(objDirFamily,
HeaderFormatError,BootSetEmpty,0));
with s = segm^^, t = rootStub^^.bootPos^^ do begin
if elements(s) <> elements(t) then
Exception(MakeResult(objDirFamily,HeaderFormatError,
0,0) );
CopyBytes ( t, s );
end;
Check( Copy (RootStub^^.BootPos,auxBootPos) );
NoCheck( NextInSet (RootStub^^.BootOwnerSet,
RootStub^^.Bootpos) );
Check(DeAlloc (RootStub^^.BootOwnerSet,auxBootPos));
end;
END;
END; (* case callMode *)
END; (* fromBoot *)
(* fromROM: not implemented *)
END; (* case loadMode *)
headerpos := headerpos + locSegmDescr.size;
END; (* for *)
(* Delete Header Segment if creating/loading from Boot Owner Set *)
IF loadMode = fromBoot THEN
BEGIN
Check( DeAlloc (RootStub^^.BootOwnerSet,refHeader) );
END;
(*$e*)
(* INSTALL, PART 7 *)
æ#b#PrintText(' Install part 7 ');#e#å
(* Create a security item for the entryNo and make the enntry public.
Verify the return of a pointer if callMode = creating *)
æØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØ
IF NOT (NoProtect OR SameEntity(ThisStub^^.Security , VOID)) THEN
BEGIN
permissions := ÆStubDelete,stubReNameÅ;
(* these two are always suggested *)
CASE loadMode OF
fromFile:
BEGIN
IF filePermit IN filePerms THEN
permissions := permissions + ÆstubpermitÅ;
IF fileRead IN filePerms OR
fileExecute IN filePerms THEN
permissions := permissions + ÆstubGetRefÅ;
(* never stubWrite? *)
END;
fromLoaded:
BEGIN
IF stubPermit IN loadPerms THEN
permissions := permissions + ÆstubPermitÅ;
IF stubGetRef IN loadPerms THEN
permissions := permissions + ÆstubGetRefÅ;
END;
(* NoProtect is always set for "fromBoot" and "fromROM",
cf.part1 *)
END; (* case *)
Result := ThisStub^^.Security.Create (fullObjName,SystemId,
permissions);
IF Result.main <> ok THEN GOTO exitlabel;
END;
ØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØå
(* Make bucket entryNo public *)
Check( ThisStub^^.DirGate.Lock );
WITH d = targetBucket^^.Entries^^, e = d ÆTargetIndexÅ DO
CASE callMode OF
creating: e.kind := generalObject;
loading: IF hPrefix.kind = programModule THEN
e.kind := loadedProgram
ELSE
e.kind := loadedLibrary;
END; (* case *)
Check( ThisStub^^.DirGate.open );
æØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØ
(* Verify that the caller may have a simple reference to the general
object returned (only for callMode = creating) *)
IF (callMode = creating) AND
(stubGetRef IN permissions OR
NoProtect OR
SameEntity(ThisStub^^.Security , VOID)) THEN
ØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØå
Check( Copy (TargetBucket^^.PtrsÆTargetIndexÅ, Obj) );
(*$e*)
(* INSTALL, EXITPART *)
do begin
(* In case of exception in this procedure control is transferred to here
The situation should be reestablished as prior to call. *)
res := GetException;
printVar ('Install Error ! Result = ', res );
(* It is not necessary to delete the security item,
since no error arise after its creation! *)
CASE callMode OF
creating: entryNokind := generalObject;
loading: IF hPrefix.kind = programModule THEN
entryNokind := loadedProgram
ELSE
entryNokind := loadedLibrary;
END;
in
CleanUpEntry (ThisStub,TargetBucket,TargetIndex,entryNokind);
do æ nothing å;
(* the fao is closed by implicit deallocation returning from
the procedure. *)
Exception ( res );
END;
end; æ exception handling å
END; (*** Install ***)
(*$e*)
æ!!!!!!!!!!!!!!!!!!!! repair of one pass compiler !!!!!!!!!!!!!!!!!!!!å
function StubTemps: integer; forward;
function StubStack: integer; forward;
æ---------------- The S T U B O B J E C T ----------------------å
PROGRAM STUBIMPLEMENT OBJECT ObjDir WITH STUBLOCALS;
PROCEDURE CheckNewName (
ObjName: fullid; (* complete or shortid *)
VAR StubRef: StubLocref;
VAR NewShortid: name16;
VAR refp, bucket: ref );
VAR base: integer;
entryNo: bucketEntry;
(* used by Load, Create, Create Access, and Insert Pointer to find
the relevant Stub into which the new entity goes *)
BEGIN
æ#b# PrintText (' CheckNewName ');#e#å
Check( Copy (EgoEnv, StubRef) );
base := 0;
if elements(objName) < 1 then
exception(MakeResult(Universal,-DataValueIllegal,nameTooShort,-1));
IF ObjNameÆ1Å <> slash THEN
BEGIN (* must be simple shortid *)
getShortid (ObjName, base, NewShortid);
IF base < LastNonBlank(ObjName) THEN
Exception(MakeResult(Universal,-DataValueIllegal,nameTooLong,-1));
IF lookup (EgoEnv,NewShortid,bucket,entryNo,refp) THEN
Exception(MakeResult(objDirFamily,-ObjectNameExists,0,0) );
END ELSE BEGIN
(* ObjName is complete *)
GetRefComplete (RootStub,ObjName,base,refp,bucket,entryNo,StubRef);
getShortid (ObjName,base,NewShortid);
IF NewShortid = NULL THEN
Exception(MakeResult(objDirFamily,
-ObjectNameExists,nameTooohort,-1));
(* because the whole ObjName were scanned by
GetCompleteRef *)
IF base < LastNonBlank (Objname) then
Exception(MakeResult(objDirFamily,
-ExtRefNotFound,nameTooLong,-1));
(* because GetCompleteRef didn't reach the end of ObjName *)
IF entryNo.kind <> subDir THEN
Exception(MakeResult(objDirFamily,
-ObjectNameExists,nameNotSubDir,-1));
END;
æ#b#PrintVar (' NewShortId = ',NewShortId);#e#å
END; (*** CheckNewName ***)
(*$e*)
PROCEDURE CheckOldName ( Name: fullid;
VAR TargetStub: StubLocref;
VAR sid: name16;
VAR refp,bucket: ref );
(* Used by Delete, Abort, and Dump to find the relevant
Stub in which "Name" exists. "Name" must be a complete
name or a shortid. In the latter case, no searching
is performed, i.e. the name must be found in this
Stub ("Name" is thus unambigous) *)
VAR base: integer;
entryNo: BucketEntry;
BEGIN
æ#b# PrintText (' CheckOldName '); #e#å
base := 0;
if elements(name) < 1 then
exception(MakeResult(Universal,-DataValueIllegal,nameTooShort,-1));
IF NameÆ1Å = slash THEN BEGIN
GetRefComplete (RootStub, Name, base,
targetStub,bucket, entryNo, refp);
IF base < LastNonBlank (Name) THEN
Exception(MakeResult(objDirFamily,
-ExtRefNotFound,nameTooLong,-1));
sid := entryNo.Name;
END ELSE BEGIN
getShortid (Name, base, sid);
IF base < LastNonBlank (Name) THEN
Exception(MakeResult(Universal,-DataValueIllegal,nameTooLong,-1));
Check( Copy (EgoEnv, TargetStub) );
END;
END; (*** CheckOldName ***)
(*$e*)
entry Init WITH RECORD
T1: ^^;
INITCONFIG: ^^;
initExtension: ref;
case integer of
1:( bucket: bucketRef);
2:(instTmp: installTemps);
END;
(* IN Source: AddrMax (optional) *)
VAR SourceAddr: integer;
i, j: integer;
size: sizeType;
name: name16;
BEGIN
æ#b# PrintText (' Init ');#e#å
(* Has Init already been called once? *)
in
IF NOT SameEntity(RootStub , VOID) THEN
Exception(MakeResult(Universal,-EntryIllegal,0,0) );
SourceAddr := 0; æ!!!!!!!!! Rom Boot not implemented !!!!!!å
PrintText ('--- ObjDir version 0.29 83-11-24 --- ');
(* Allocate Local Data Segm *)
NoCheck(ClearSize(size));
NoCheck(AddSeg(size,bytes(stubData)));
Check( Allocate.NewObj (out localData; size, i ) );
Check( DeclSeg (LocalData,bytes(stubdata) ) );
(* initialize local data *)
WITH d = LocalData^^ DO
d.StubName := RootName;
(* Initialize locals *)
Check( Scheduler.NewGate ( OUT DirGate) );
in
Check ( Copy(Code,BootPos) );
Check ( NextInSet ( BootOwnerSet, BootPos ) );
do begin
æ Stub is not self in BootSet å
Check( FirstInSet (BootOwnerSet,BootPos) );
end;
Check( Copy (EgoEnv,RootStub) );
(* Create Standard name entries *)
GlobalInsertPtr (EgoEnv,AllocName,Allocate,true,bucket);
GlobalInsertPtr (EgoEnv,SchedName,Scheduler,true,bucket);
GlobalInsertPtr (EgoEnv,IntName,Intscheduler,true,bucket);
GlobalInsertPtr (EgoEnv,ObjDirName,Ego,true,bucket);
(* Make Reentrant *)
Check ( MakeReentrant ( EgoEnv ) );
(* Create InitConfig *)
name := ConfigName;
Install (EgoEnv,creating,name,NULL, 0,
true (* New Subject *), true (* No Protect *),
InitConfig, instTmp );
Check( allocate.NewObj( out initExtension;
makeSize ( initUserSize, initKernelSize), 0 ) );
Check( CallExtend(initExtension,InitConfig,1)); æ Extended Stack å
GlobalDelete (EgoEnv,ConfigName, bucket);
do begin æ error in boot å
printStack (' !!!!!!!!!!!!!!!!!! B O O T E R R O R !!!!!!!!!!!!!!!!!' );
end;
END; (*** Init ***)
(*$e*)
entry GetRef WITH Record
t1: ref;
workRef1, workRef2, workRef3: ref;
end;
(* OUT Obj:Ref;
IN Name: fullid; (complete or simple)
OUT used: integer;
OUT kind: ItemKndType *)
BEGIN
æ#b# PrintText (' GetRef ');#e#å
æØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØ
Result := Allocate.GetId (1, CallersSubject, UserId);
ØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØå
GlobalGetRef (EgoEnv,Name,used,
Obj,kind,workRef1,workRef2, workRef3 );
if elements(name) > used then
if nameÆused+1Å = slash then used := used + 1;
END; (*** GetRef ***)
(*$e*)
entry Load WITH RECORD
T1: ref;
TARGETSTUB: stubLocRef;
OBJ: Ref;
case integer of
1:( instTmp: installTemps );
2:( workRef1, workRef2: ref );
END;
(* INOUT ObjName: fullid;
IN SourceName: fullid;
IN NoProtect: protectType -- optional *)
VAR
sid: name16;
NoProtect: boolean;
BEGIN
æ#b# PrintText (' load ');#e#å
CheckNewName (ObjName,TargetStub,sid, workRef1, workRef2 );
Install (TargetStub,loading,sid,SourceName,
0,false,true,Obj,instTmp );
with d = targetStub^^.LocalData^^ do
ConcatNames(d.stubName, sid, objName);
END; (*** Load ***)
(*$e*)
entry Create WITH Record
T1: ref;
TargetStub: stubLocRef;
case integer of
1:( instTmp: installTemps );
2:( workRef1, workRef2: ref );
END;
(* OUT Obj: ref;
IN OUT ObjName: fullid;
IN SourceName: fullid;
IN NoProtect: protectType -- optional
IN NewSubject: newSubType -- optional *)
VAR
sid: name16;
NewSubject: boolean;
NoProtect: boolean;
BEGIN
æ#b# PrintText (' Create ');#e#å
CheckNewName (ObjName,TargetStub,sid,workRef1, workRef2);
æØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØ
IF NOT NextValArg (NoProtect) THEN NoProtect := false;
IF NOT NextValArg (NewSubject) THEN NewSubject := false;
ØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØå
NoProtect := true; NewSubJect := false;
Install (TargetStub,creating,sid,SourceName,
0,NewSubject,NoProtect,Obj,instTmp );
with d = targetStub^^.LocalData^^ do
ConcatNames(d.stubName, sid, objName);
END; (*** Create ***)
(*$e*)
entry CreateAccess WITH Record
T1: ref;
TargetStub: stubLocRef;
TargetBucket: bucketRef;
END;
(* OUT Obj: ^^; simple pointer to the created access obj
IN Creator: ^^;
IN Name: fullid; -- complete or simple --
NoProtect: boolean;
IN Entry: integer; -- Entry to be called in "creator" *)
æØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØ
VAR
sid: shortid;
TargetIndex: integer;
Result: ResultType;
i: integer;
param: ARRAY lo..hi: Natural OF byte;
permissions: StubSecurityItem;
fullNewName: fullid;
SystemId: SubjectIdentification;
ØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØå
BEGIN
æ#b# PrintText (' create access ');#e#å
Exception(MakeResult(Universal,-EntryIllegal,0,0) );
æØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØ
CheckNewName (Result Name,TargetStub,sid);
IF Result.main <> ok THEN ObjReturn (GetException);
IF NOT OccupyFree (TargetStub,sid,TargetBucket,TargetIndex) THEN
BEGIN
SetResult (Result,Rejected,NoResources,objDirFamily,0,35);
ObjReturn(GetException);
END;
(* Define parameters for the call to "Creator" *)
DefParams (OUT TargetBucket^^ÆTargetIndexÅ);
FOR i := 3 TO EntryArgs.NoOfFormals DO
DefParams (INOUT Formal (i));
WHILE NextValArg (param) DO
DefParams (INOUT param);
Creator.Entry (Result);
IF Result.main <> ok THEN goto exit;
(* return simple ptr *)
Result := Copy (TargetBucket^^ÆTargetIndexÅ,Formals(2));
IF NOT SameEntity(Security , void) THEN
BEGIN (* Create a security item for the access object :)
permissions := ÆstubDelete,stubReName(?)Å
WITH d = TargetStub^^.LocalData^^ DO
concatNames (Result d.StubName,sid,fullNewName);
(* necessary *)
IF Result.main <> ok THEN GOTO exit (* NameTooLong *)
Result := Allocate.GetId (1,SystemId);
IF Result,main <> ok THEN
GOTO exit;
Result := Security.Create (fullNewName,SystemId,
permissions);
IF Result.main <> ok THEN
GOTO exit;
END;
(* Make the entryNo public *)
WITH d = TargetBucket^^.Entries^^ DO
Result := TargetStub^^.DirGate.Lock
WITH e = dÆTargetIndexÅ DO
BEGIN
e.Name := sid;
e.PtrIndex := TargetIndex;
e.NoProtect := false;
(* could be returned by creator *)
e.kind := Access;
END;
Result := TargetStub^^.DirGate.open;
exit:
IF Result.main <> ok THEN
BEGIN (* clean up *)
(* No security item exists since no error can arise after
the "Security.Create" call. *)
CleanUpEntry (EgoEnv,TargetBucket,TargetIndex,Access);
END;
ObjReturn (GetException);
ØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØå
END; (*** Create Access ***)
(*$e*)
entry InsertPointer WITH Record
T1: ref;
TargetStub: stubLocRef;
workRef1, workRef2: ref;
END;
(* IN Ptr: ref;
IN Name: fullid; (complete or simple)
IN NoProtect: protectType *)
VAR
sid: name16;
BEGIN
æ#b# PrintText (' InsertPointer ');#e#å
CheckNewName (Name,TargetStub,sid,workRef1,workRef2);
GlobalInsertPtr (TargetStub,sid,Ptr,true,workRef1);
END; (*** InsertPointer ***)
(*$e*)
entry ReName
(* IN OldName,
NewName: shortid *)
with record
t1: ref;
bucket1,
bucket2: Bucketref;
end;
var
entryNo1,
entryNo2: BucketEntry;
sid1, sid2: name16;
BEGIN
æ#b# PrintText (' Rename ');#e#å
FillBytes(' ',sid1);
FillBytes(' ',sid2);
if not NameOk(OldName) then
ObjReturn(MakeResult(Universal,-DataValueIllegal,nameError,-1));
if not NameOk(NewName) then
ObjReturn(MakeResult(Universal,-DataValueIllegal,nameError,-2));
CopyBytes(OldName,sid1);
CopyBytes(NewName,sid2);
Check ( DirGate.Lock );
in
IF LookUpEntry (EgoEnv,sid1,bucket1,entryNo1) THEN BEGIN
æØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØ
IF NOT VerifyOperation (StubDelete,EgoEnv,OldName) THEN
BEGIN
SetResult (Result,Rejected,ExtRefProtected,objDirFamily,0,51);
ObjReturn(GetException);
END;
ØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØå
IF LookUpEntry (EgoEnv,sid2,bucket2,entryNo2) THEN
Exception(MakeResult(objDirFamily,-ObjectNameExists,0,-2) );
WITH d = bucket1^^.Entries^^ DO
dÆentryNo1.indexÅ.Name := sid2;
END ELSE BEGIN
Exception(MakeResult(objDirFamily,-ExtRefNotFound,0,-1) );
END;
do begin
check(dirGate.open);
end;
END; (*** ReName ***)
(*$e*)
entry DeleteItem WITH Record
T1: ref;
TargetStub: stubLocRef;
workRef1, workRef2: ref;
END;
(* IN Name: fullid (simple or complete) *)
VAR
sid: name16;
BEGIN
æ#b# PrintText (' Delete ');#e#å
æØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØ
IF NOT VerifyOperation (stubDelete,EgoEnv,Name) THEN
BEGIN
SetResult (Result,Rejected,ExtRefProtected,objDirFamily,0,54);
ObjReturn(GetException);
END;
ØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØå
CheckOldName (Name,TargetStub,sid,workRef1, workRef2);
GlobalDelete (TargetStub,sid,workRef1);
END; (*** Delete ***)
(*$e*)
entry AbortObj WITH Record
T1: ref;
TargetStub: stubLocRef;
Bucket: bucketRef;
refp: ref;
workRef1: ref;
env: ref;
END;
(* IN Name = fullid (complete or simple) *)
(* Aborts a Callable Module *)
VAR i: integer;
sid: name16;
entryNo: BucketEntry;
BEGIN
æ#b# PrintText (' Abort '); #e#å
CheckOldName (Name,TargetStub,sid,refp,workRef1 );
æØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØ
IF NOT VerifyOperation (stubDelete,TargetStub,sid) THEN
BEGIN
SetResult (Result,Rejected,ExtRefProtected,objDirFamily,0,70);
END;
ØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØå
IF lookup (TargetStub,sid,bucket,entryNo,refp) THEN
BEGIN
IF entryNo.kind <> generalObject THEN
Exception(MakeResult(Universal,-EntryIllegal,NotCallable,0));
æ!!!!!!!!!!!!!!!!! order of arguments to inspObj !!!!!!!!!!!!!!!å
NoCheck( InspObj (TargetStub,env,refp,i) );
NoCheck( Abort (env) );
END ELSE
Exception(MakeResult(objDirFamily,-ExtRefNotFound, 0,0));
(* must have been deleted between calls of
"CheckOldName" and "lookup" *)
END; (*** AbortObj ***)
(*$e*)
private termSubDir ( objOwner:ref; env: stubLocRef ) WITH Record
T1: ^^;
TargetBucket: ^^BucketLocals;
END;
(* Removes the bucket entryNo for a stub being deleted *)
VAR TargetIndex: integer;
BEGIN
æ#b# PrintText (' termSubDir '); #e#å
WITH d = env^^.LocalData^^ DO
targetIndex := d.MotherIndex;
Check ( Copy (env^^.MotherBucket,TargetBucket) );
WITH d = TargetBucket^^.Entries^^ DO
dÆTargetIndexÅ.kind := FreeEntry;
END; (*** termSubDir ***)
(*$e*)
entry NewSubDir WITH Record
T1: ref;
targetStub, StubEnv: stubLocRef;
targetBucket: bucketRef;
workRef1, workRef2: ref;
END;
(* OUT ObjDirOwner: ObjDirRefType;
IN Name: shortid; *)
var
sid: name16;
size: sizeType;
i, targetIndex: integer;
BEGIN
æ#b# PrintText (' SubDir '); #e#å
CheckNewName ( name, targetStub, sid, workRef1, workRef2 );
NoCheck(ClearSize (size));
NoCheck(AddGen (size,refs (StubLocals)));
NoCheck(AddSeg (size, bytes (StubData)));
Check ( Allocate.NewObj (objDirOwner;size,OUT i ));
Check ( DeclGen (objDirOwner,SubStubs,StubEnv,refs (StubLocals),
TermSubDir, MakeSize(0,0),MakeSize(-1,-1),StubTemps,
StubStack,0,addr (stubimplement),
MakeSize(0,0),true) );
Check ( NewSeg (StubEnv^^.LocalData,bytes( StubData)));
Check ( Copy (code,StubEnv^^.code));
Check ( Copy (Allocate,StubEnv^^.Allocate));
Check ( Copy (Scheduler,StubEnv^^.Scheduler));
Check ( Copy (RootStub,StubEnv^^.RootStub));
Check ( Copy (StubEnv,StubEnv^^.EgoEnv));
Check ( Copy (ObjDirOwner,StubEnv^^.Ego));
Check ( Copy (targetStub,StubEnv^^.MotherStub));
Check ( Scheduler.NewGate (OUT StubEnv^^.DirGate));
GlobalInsertPtr (StubEnv,ObjDirName,ObjDirOwner,true,
targetBucket æworkKpå );
Check ( MakeReentrant ( StubEnv ) );
(* insert bucketEntry *)
IF NOT OccupyFree (targetStub, sid, TargetBucket, TargetIndex) THEN
Exception(MakeResult(Universal,-NoResources, NoBuckets,0) );
WITH d = TargetBucket^^.Entries^^, e = d ÆTargetIndexÅ DO
BEGIN
e.Name := sid;
e.Index := TargetIndex;
e.NoProtect := true;
(* e.kind is not touched: it is "LockedEntry" until
further *)
END;
WITH new = StubEnv^^.LocalData^^,
old = targetStub^^.LocalData^^ DO BEGIN
new.MotherIndex := targetIndex;
concatNames(old.stubName, name, new.stubName);
END;
Check( Copy (targetBucket,StubEnv^^.MotherBucket));
Check( Copy (StubEnv,targetBucket^^.PtrsÆtargetIndexÅ));
(* Make bucket entryNo public *)
Check( targetStub^^.DirGate.Lock );
WITH d = targetBucket^^.Entries^^, e = d ÆTargetIndexÅ DO
e.kind := subDir;
Check( targetStub^^.DirGate.open );
END; (*** SubDir ***)
(*$e*)
entry GetDirName WITH Record T1: ref; END;
(* OUT Name: Fullid (complete) *)
BEGIN
æ#b# PrintText (' GetDirName ');#e#å
WITH d = LocalData^^ DO begin
FillBytes (' ', name );
CopyBytes (d.StubName, name );
end;
END; (*** GetStubName ***)
(*$e*)
entry InitItemScan WITH Record
T1: ref;
Env: scanLocRef;
END;
(* OUT ScanOwner: IScanRefType *)
VAR
size: SizeType;
i: integer;
BEGIN
æ#b# PrintText (' Initscan '); #e#å
NoCheck(Dealloc(bootProc,bootProc)); æremove bootproc, if possibleå
NoCheck(ClearSize(size));
NoCheck(AddGen (size, refs (ScanLocals)));
NoCheck(AddEmbSeg (size, bytes (scanData)));
StopCheck(Allocate.NewObj(ScanOwner;size, OUT i));
Check(DeclGen (ScanOwner,ScanSet,env,refs (ScanLocals),
0,makeSize(0,0),makeSize(-1,-1),
refs (Scanimplement), bytes(ScanImplement),
0,addr(ScanImplement),makeSize(0,0),true ));
Check(NewSeg (env^^.Data,bytes(scanData) ) );
Check(Copy (EgoEnv,env^^.MotherStub));
Check(Copy (code, env^^.code ) );
in
StopCheck( FirstInSet (Buckets,env^^.currBucket));
do
objReturn(MakeResult(objDirFamily,-ExtRefNotFound,0,0));
with env^^.data^^ do lastI := 0;
END; (*** InitScan ***)
æØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØ
entry PROCEDURE UseAlloc;
(* IN AllocPtr: ^^Alloc;
IN IdentPtr: ^^Ident *)
VAR Result: ResultType;
BEGIN
PrintText (' Use alloc ');
IF NOT SameEntity(IdentObj , void) THEN
BEGIN
SetResult (Result,Rejected,EntryIllegal,Universal,0,0);
ObjReturn(GetException);
END;
IF NOT SameEntity(RootStub , EgoEnv) THEN
BEGIN
SetResult (Result,Rejected,EntryIllegal,Universal,0,0);
ObjReturn(GetException);
END;
Result:= Copy ( AllocPtr,Allocate);
Result:= Copy ( IdentPtr, IdentObj);
ObjReturn (GetException);
END; (*** UseAlloc ***)
entry PROCEDURE Use Security;
(* IN SecurityPtr: ^^SecuritySys;
IN SystemManPtr: ^^SystemMan *)
VAR Result: ResultType;
BEGIN
PrintText (' Use Security ');
IF NOT Security := void THEN Return (Called Once);
IF NOT RootStub := EgoEnv THEN Return (NotRoot);
Result:= Copy ( SecurityPtr,Security);
Result:= Copy ( SystemManPtr,SystMan);
ObjReturn (GetException);
END; (*** Use Security ***)
ØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØå
(*$e*)
entry SpeedUpObj WITH Record
T1: ref;
TargetStub: stubLocRef;
Bucket: bucketRef;
refp: ref;
workRef1: ref;
env: ref;
END;
(* IN Name = fullid (complete or simple) *)
(* Speeds up a Callable Module *)
VAR i: integer;
sid: name16;
entryNo: BucketEntry;
BEGIN
æ#b# PrintText (' SpeedUpObj '); #e#å
CheckOldName (Name,TargetStub,sid,refp,workRef1 );
æØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØ
IF NOT VerifyOperation (stubDelete,TargetStub,sid) THEN
BEGIN
SetResult (Result,Rejected,ExtRefProtected,objDirFamily,0,70);
END;
ØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØØå
IF lookup (TargetStub,sid,bucket,entryNo,refp) THEN
BEGIN
IF entryNo.kind <> generalObject THEN
Exception(MakeResult(Universal,-EntryIllegal,NotCallable,0));
æ!!!!!!!!!!!!!!!!! order of arguments to inspObj !!!!!!!!!!!!!!!å
NoCheck( InspObj (TargetStub,env,refp,i) );
NoCheck( SpeedUp (env) );
END ELSE
Exception(MakeResult(objDirFamily,-ExtRefNotFound, 0,0));
(* must have been deleted between calls of
"CheckOldName" and "lookup" *)
END; (*** speedUpObj ***)
otherwise stubOther with record
t1: ref;
end;
begin
Exception(MakeResult(Universal,entryIllegal,0,0) );
end;
END; (***** Stub program *****)
æ!!!!!!!!!!!!!!!!!!!! repair of one pass compiler !!!!!!!!!!!!!!!!!!!!å
function StubTemps;
begin StubTemps := refs (StubImplement); end;
function StubStack;
begin StubStack := bytes (StubImplement); end;
initialise stubImplement 'objdir':
allocate 'alloc',
scheduler 'sched',
ego '*',
egoEnv '**'
end.
«eof»