reduce-historical/psl-1983/kernel/property-list.red

%
% PROPERTY-LIST.RED - Functions dealing with property lists
% 
% Author:      Eric Benson
%	       Symbolic Computation Group
%              Computer Science Dept.
%              University of Utah
% Date:        17 August 1981
% Copyright (c) 1981 University of Utah
%

%  <PSL.INTERP>PROPERTY-LIST.RED.11,  1-Mar-82 14:09:20, Edit by BENSON
%  Changed "move-to-front" to "exchange-with-previous"
%  <PSL.INTERP>PROPERTY-LIST.RED.7, 27-Feb-82 12:43:27, Edit by BENSON
%  Optimized GET and FLAGP, rearranges property list

% Every ID in the system has a property list.  It is obtained by the function
% PROP(ID) and updated with the function SETPROP(ID, PLIST).  These functions
% are not in the Standard Lisp report, and are not intended for use in user
% programs.  A property list (whose format should also not be known to
% user programs) is a list of IDs and dotted pairs (A-List entries).  The
% pairs are used by PUT and GET, and the IDs are used by FLAG and FLAGP.

% Non-Standard Lisp functions used:
% DELQIP -- EQ, destructive version of Delete	(in EASY-NON-SL.RED)
% ATSOC -- EQ version of ASSOC	(in EASY-NON-SL.RED)
% DELATQIP -- EQ, destructive version of DELASC (in EASY-NON-SL.RED)
% EQCAR(A,B) -- PairP A and car A eq B (in EASY-NON-SL.RED)
% NonIDError -- in TYPE-ERRORS.RED

on SysLisp;

syslsp procedure Prop U;		%. Access property list of U
    if IDP U then SymPrp IDInf U
    else NonIDError(U, 'Prop);

syslsp procedure SetProp(U, L);		%. Store L as property list of U
    if IDP U then
	SymPrp IDInf U := L
    else
	NonIDError(U, 'SetProp);

syslsp procedure FlagP(U, Indicator); 	%. Is U marked with Indicator?
    if not IDP U or not IDP Indicator then NIL
    else begin scalar PL, PreviousPointer;
	PL := SymPrp IDInf U;
	if null PL then return NIL;
	if car PL eq Indicator then return T;
	PreviousPointer := PL;
	PL := cdr PL;
Loop:
	if null PL then return NIL;
	if car PL eq Indicator then return
	<<  Rplaca(PL, car PreviousPointer);
	    Rplaca(PreviousPointer, Indicator);
	    T >>;
	PreviousPointer := PL;
	PL := cdr PL;
	goto Loop;
    end;

on FastLinks;

syslsp procedure GetFnType U;
    get(U, 'TYPE);

off FastLinks;

syslsp procedure Get(U, Indicator); %. Retrieve value stored for U with Ind
    if not IDP U or not IDP Indicator then NIL
    else begin scalar PL, X, PreviousPointer;
	PL := SymPrp IDInf U;
	if null PL then return NIL;
	X := car PL;
	if PairP X and car X eq Indicator then return cdr X;
	PreviousPointer := PL;
	PL := cdr PL;
Loop:
	if null PL then return NIL;
	X := car PL;
	if PairP X and car X eq Indicator then return
	<<  Rplaca(PL, car PreviousPointer);
	    Rplaca(PreviousPointer, X);
	    cdr X >>;
	PreviousPointer := PL;
	PL := cdr PL;
	goto Loop;
    end;

off SysLisp;

lisp procedure Flag(IDList, Indicator);	%. Mark all in IDList with Indicator
    if not IDP Indicator then
	NonIDError(Indicator, 'Flag)
    else
	for each U in IDList do Flag1(U, Indicator);

lisp procedure Flag1(U, Indicator);
    if not IDP U then
	NonIDError(U, 'Flag)
    else begin scalar PL;
	PL := Prop U;
	if not (Indicator memq PL) then SetProp(U, Indicator . PL);
    end;

lisp procedure RemFlag(IDList, Indicator); %. Remove marking of all in IDList
    if not IDP Indicator then
	NonIDError(Indicator, 'RemFlag)
    else
	for each U in IDList do RemFlag1(U, Indicator);

lisp procedure RemFlag1(U, Indicator);
    if not IDP U then
	NonIDError(U, 'RemFlag)
    else SetProp(U, DelQIP(Indicator, Prop U));


lisp procedure Put(U, Indicator, Val);	%. Store Val in U with Indicator
    if not IDP U then
	NonIDError(U, 'Put)
    else if not IDP Indicator then
	NonIDError(Indicator, 'Put)
    else begin scalar PL, V;
	PL := Prop U;
	if not (V := Atsoc(Indicator, PL)) then
	    SetProp(U, (Indicator . Val) . PL)
	else
	    RPlacD(V, Val);
	return Val;
    end;

lisp procedure RemProp(U, Indicator);	%. Remove value of U with Indicator
    if not IDP U or not IDP Indicator then NIL
    else begin scalar V;
	if (V := get(U, Indicator)) then
	    SetProp(U, DelAtQIP(Indicator, Prop U));
	return V;
    end;


lisp procedure RemPropL(L, Indicator);	%. RemProp for all IDs in L
    for each X in L do RemProp(X, Indicator);

END;