%
% OBLIST.RED - Intern, RemOb and friends
%
% Author: Eric Benson
% Symbolic Computation Group
% Computer Science Dept.
% University of Utah
% Date: 27 August 1981
% Copyright (c) 1981 University of Utah
%
% <PSL.INTERP>OBLIST.RED.9, 15-Sep-82 09:35:25, Edit by BENSON
% InternP accepts a string as well as a symbol
% CopyString and CopyStringToFrom are found in COPIERS.RED
CompileTime flag('(AddToObList LookupOrAddToObList InObList
InitNewID GenSym1),
'InternalFunction);
on SysLisp;
internal WConst DeletedSlotValue = -1,
EmptySlotValue = 0;
CompileTime <<
syslsp smacro procedure DeletedSlot U;
ObArray U eq DeletedSlotValue;
syslsp smacro procedure EmptySlot U;
ObArray U eq EmptySlotValue;
syslsp smacro procedure NextSlot H;
if H eq MaxObArray then 0 else H + 1;
% StringEqual found in EQUAL.RED
syslsp smacro procedure EqualObArrayEntry(ObArrayIndex, S);
StringEqual(SymNam ObArray ObArrayIndex, S);
>>;
syslsp procedure AddToObList U;
%
% U is an ID, which is added to the oblist if an ID with the same
% print name is not already there. The interned ID is returned.
%
begin scalar V, W, X, Y;
W := IDInf U;
U := StrInf SymNam W;
Y := StrLen U;
if Y < 0 then return StdError '"The null string cannot be interned";
if Y eq 0 then return MkID StrByt(U, 0);
return if OccupiedSlot(V := InObList U) then MkID ObArray V
else
<< ObArray V := W;
X := GtConstSTR Y;
CopyStringToFrom(X, U);
SymNam W := MkSTR X;
MkID W >>;
end;
syslsp procedure LookupOrAddToObList U;
%
% U is a String, which IS copied if it is not found on the ObList
% The interned ID with U as print name is returned
%
begin scalar V, W, X, Y;
U := StrInf U;
Y := StrLen U;
if Y < 0 then return StdError '"The null string cannot be interned";
if Y eq 0 then return MkID StrByt(U, 0);
return if OccupiedSlot(V := InObList U) then MkID ObArray V
else
<< W := GtID(); % allocate a new ID
ObArray V := W; % plant it in the Oblist
X := GtConstSTR Y; % allocate a string from uncollected
CopyStringToFrom(X, StrInf U); % space
InitNewID(W, MkSTR X) >>;
end;
syslsp procedure NewID S; %. Allocate un-interned ID with print name S
InitNewID(GtID(), S); % Doesn't copy S
syslsp procedure InitNewID(U, V); % Initialize cells of an ID to defaults
<< SymNam U := V;
U := MkID U;
MakeUnBound U;
SetProp(U, NIL);
MakeFUnBound U;
U >>;
syslsp procedure HashFunction S; % Compute hash function of string
begin scalar Len, HashVal; % Fold together a bunch of bits
S := StrInf S;
HashVal := 0; % from the first BitsPerWord - 8
Len := StrLen S; % chars of the string
if Len > BitsPerWord - 8 then Len := BitsPerWord - 8;
for I := 0 step 1 until Len do
HashVal := LXOR(HashVal, LSH(StrByt(S, I), (BitsPerWord - 8) - I));
return MOD(HashVal, MaxObArray);
end;
syslsp procedure InObList U; % U is a string. Returns an ObArray pointer
begin scalar H, DSlot, WalkObArray;
H := HashFunction U;
WalkObArray := H;
DSlot := -1;
Loop:
if EmptySlot WalkObArray then return
if DSlot neq -1 then
DSlot
else
WalkObArray
else if DeletedSlot WalkObArray and DSlot eq -1 then
DSlot := WalkObArray
else if EqualObArrayEntry(WalkObArray, U) then return
WalkObArray;
WalkObArray := NextSlot WalkObArray;
if WalkObArray eq H then FatalError "Oblist overflow";
goto Loop;
end;
syslsp procedure Intern U; %. Add U to ObList
%
% U is a string or uninterned ID
%
if IDP U then
AddToObList U
else if StringP U then
LookupOrAddToObList U
else
TypeError(U, 'Intern, '"ID or string");
syslsp procedure RemOb U; %. REMove id from OBlist
begin scalar V;
if not IDP U then return
NonIDError(U, 'RemOb);
V := IDInf U;
if V < 128 then return
TypeError(U, 'RemOb, '"non-char");
V := SymNam V;
return
<< if OccupiedSlot(V := InObList V) then
ObArray V := DeletedSlotValue;
U >>
end;
% Changed to allow a string as well as a symbol, EB, 15 September 1982
syslsp procedure InternP U; %. Is U an interned ID?
if IDP U then
<< U := IDInf U;
U < 128 or U eq ObArray InObList SymNam U >>
else if StringP U then
StrLen StrInf U eq 0 or OccupiedSlot InObList U
else NIL;
internal WString GenSymPName = "G0000";
syslsp procedure GenSym(); %. GENerate unique, uninterned SYMbol
<< GenSym1 4;
NewID CopyString GenSymPName >>;
syslsp procedure GenSym1 N; % Auxiliary function for GenSym
begin scalar Ch;
return if N > 0 then
if (Ch := StrByt(GenSymPName, N)) < char !9 then
StrByt(GenSymPName, N) := Ch + 1
else
<< StrByt(GenSymPName, N) := char !0;
GenSym1(N - 1) >>
else % start over
<< StrByt(GenSymPName, 0) := StrByt(GenSymPName, 0) + 1;
GenSym1 4 >>;
end;
syslsp procedure InternGenSym(); %. GENerate unique, interned SYMbol
<< GenSym1 4;
Intern MkSTR GenSymPName >>;
syslsp procedure MapObl F; %. Apply F to every interned ID
<< for I := 0 step 1 until 127 do Apply(F, list MkID I);
for I := 0 step 1 until MaxObArray do
if OccupiedSlot I then Apply(F, list MkID ObArray I) >>;
% These functions provide support for multiple oblists
% Cf PACKAGE.RED for their use
internal WVar LastObArrayPtr;
syslsp procedure GlobalLookup S; % Lookup string S in global oblist
if not StringP S then NonStringError(S, 'GlobalLookup)
else if OccupiedSlot(LastObArrayPtr := InObList S) then
MkID ObArray LastObArrayPtr
else '0;
syslsp procedure GlobalInstall S; % Add new ID with PName S to oblist
begin scalar Ind, PN;
Ind := GlobalLookup S;
return if Ind neq '0 then Ind
else
<< Ind := GtID();
ObArray LastObArrayPtr := Ind;
PN := GtConstSTR StrLen StrInf S; % allocate a string from uncollected
CopyStringToFrom(PN, StrInf S); % space
InitNewID(Ind, MkSTR PN) >>;
end;
syslsp procedure GlobalRemove S; % Remove ID with PName S from oblist
begin scalar Ind;
Ind := GlobalLookup S;
return if Ind eq '0 then '0
else
<< Ind := ObArray LastObArrayPtr;
ObArray LastObArrayPtr := DeletedSlotValue;
MkID Ind >>;
end;
syslsp procedure InitObList();
begin scalar Tmp;
if_system(MC68000, << % 68000 systems don't clear memory statically
for I := 0 step 1 until MaxObArray do
ObArray I := EmptySlotValue >>);
Tmp := NextSymbol - 1;
for I := 128 step 1 until Tmp do
ObArray InObList SymNam I := I;
end;
off SysLisp;
StartupTime InitObList();
END;