Artifact 55ca349791c03f082653224ed23f0ef1e290ea9030aebca7120ee82171e7231d:

• File psl-1983/3-1/kernel/oblist.red — part of check-in [eb17ceb7f6] at 2020-04-21 19:40:01 on branch master — Add Reduce 3.0 to the historical section of the archive, and some more
  files relating to version sof PSL from the early 1980s. Thanks are due to
  Paul McJones and Nelson Beebe for these, as well as to all the original
  authors.

  git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 6515) [annotate] [blame] [check-ins using] [more...]

• File psl-1983/kernel/oblist.red — part of check-in [eb17ceb7f6] at 2020-04-21 19:40:01 on branch master — Add Reduce 3.0 to the historical section of the archive, and some more
  files relating to version sof PSL from the early 1980s. Thanks are due to
  Paul McJones and Nelson Beebe for these, as well as to all the original
  authors.

  git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 6515) [annotate] [blame] [check-ins using]

%
% 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;