File psl-1983/3-1/util/package.red artifact 4af7c710cd on branch master


%
% PACKAGE.RED - Start of small package system
%
% Author:      Martin Griss 
%	       Symbolic Computation Group
%              Computer Science Dept.
%              University of Utah
% Date:        Friday, 23 October 1981
% Copyright (c) 1981 University of Utah
%

% Idea is that Hierachical ObLists created
% Permit Root at NIL, ie Forest Of Trees
% CurrentPackage!* is Name of package
% Structure [Name,Father,Getfn,PutFn,RemFn,MapFn] under 'Package
% Have set of Localxxxx(s) and Pathxxxx(s) for
%  xxxx= InternP Intern RemOb MapObl
% By Storing Functions, have possibility of different
%   Oblist models at each level (Abstract data Type for Local Obarray )

CompileTime <<
Lisp Procedure PACKAGE x;                %. Called from Token reader
   NIL;                %  dummy            % To chnge package
>>;

Fluid '(\CurrentPackage!*		 %. Start of Search Path
        \PackageNames!*                  %. List of ALL package names
	PackageCharacter!*		%. Character prefix for package
 );

PackageCharacter!* := char !\;		% used for output

Global '(SymPak!* MaxSym!*);             % Dummy Package Field, to be SYSLSP
<<MaxSym!*:=8000;
  SymPak!*:=Mkvect MaxSym!*; 
  MaxSym!*>>;

Lisp  procedure SymPak d;                % Access SYPAK field
  SymPak!*[d];

Lisp  procedure PutSymPak(d,v);
  SymPak!*[d]:=v;

CompileTime Put('SymPak,'Assign!-op,'PutSymPak);

% -Hook in GetFn,PutFn, RemFn and MapFn for \Global ------

CopyD('GlobalMapObl,'MapObl);

Lisp Procedure \SetUpInitialPackage;
Begin
 Put('\Global,'\Package, 
     '[\Global NIL \GlobalLookup \GlobalInstall \GlobalRemove \GlobalMapObl]);
 % Package is [name of self, father, GetFn, PutFn,RemFn,MapFn]
 \PackageNames!* := '(\Global);
 \CurrentPackage!* := '\Global;
End;

CompileTime <<
Lisp Smacro Procedure PackageName x;
  x[0];

Lisp Smacro Procedure PackageFather x;
  x[1];

Lisp Smacro Procedure PackageGetFn x;
  x[2];

Lisp Smacro Procedure PackagePutFn x;
  x[3];

Lisp Smacro Procedure PackageRemFn x;
  x[4];

Lisp Smacro Procedure PackageMapFn x;
  x[5];
>>;

\SetupInitialPackage();

Lisp Procedure \PackageP(Name);		%. test if legal package
  IdP(Name) and Get(Name,'\Package);

Lisp Procedure \CreateRawPackage(Name,Father, GetFn, PutFn, RemFn, MapFn); 
                  %. Build New Package
 Begin Scalar V;
      If \PackageP Name then 
        return ErrorPrintF("*** %r is already a package",Name);
      If Not \PackageP Father then
        return ErrorPrintF("*** %r cant be Father package",Father);
      V:=Mkvect(5);
      V[0]:=Name;
      V[1]:=Father;
      V[2]:=GetFn;
      V[3]:=PutFn; 
      V[4] := RemFn;
      V[5] := MapFn;
      \PackageNames!* := Name . \PackageNames!*;
      Put(Name,'\Package,V);
      Return V
 End;

Lisp Procedure \SetPackage(Name); 		%. Change Default
 If \PackageP(Name) then
    <<%PrintF(" Pack: %r->%r %n",\CurrentPackage!*,Name);
      \CurrentPackage!*:=Name>>

  else if Null Name then \SetPackage('\Global)
  else \PackageError(Name);

Lisp procedure \PackageError(Name);
 Error(99, LIST(Name, " Is not a Package "));

% Note that we have to cleanup to some default package if
% there is an error during ID name reading:

CopyD('UnSafeToken,'ChannelReadToken);

Lisp Procedure SafeToken(Channel);
  (LAMBDA (\CurrentPackage!*); UnSafeToken(Channel)) (\CurrentPackage!*);

CopyD('ChannelReadToken,'SafeToken);

Lisp Procedure PACKAGE x;                %. Called from Token reader
 \SetPackage x;

% --- User Package Stuff
% --- Simple Buck Hash, using PAIRs (could later use Blocks)

lisp Procedure HashFn(S,Htab);
begin scalar Len, HashVal;		% Fold together a bunch of bits
    S := StrInf S;
    HashVal := 0;			% from the first 28 characters of the
    Len := StrLen S;			% string.
    if IGreaterP(Len, 25) then Len := 25;
    for I := 0 step 1 until Len do
	HashVal := ILXOR(HashVal, ILSH(StrByt(S, I), IDifference(25, I)));
    return  IRemainder(HashVal, VecLen VecInf Htab);
end;

Lisp Procedure HashGetFn(S,Htab);         %. See if String S is There
 % Htab is Vector of Buckets
 Begin Scalar H,Buk,Hashloc;
    If not StringP S then Return NonStringError(S,'HashGetFn);
    HashLoc:=HashFn(S,Htab);
    Buk:=Htab[HashLoc];
Loop: If Null Buk then return 0;
      H:=Car Buk; Buk:=cdr Buk;
      If S=ID2String H then return H;
      goto Loop;
End;

Lisp Procedure HashPutFn(S,Htab);    %. Install String at HashLoc
 Begin Scalar H,TopBuk,Buk,HashLoc;
    If not StringP S then NonStringError(S,'HashPutFn);
    HashLoc :=HashFn(S,Htab);
    TopBuk:=Buk:=Htab[HashLoc];
Loop: If Null Buk then goto new;
      H:=Car Buk; Buk:=cdr Buk;
      If S=ID2String H then return H;
      goto Loop;
New:
    S:=CopyString S;   % So doesnt grab I/O buffer
    H:=NewID  S;
    SymPak(ID2Int H) := CurrentPackage!*;
    TopBuk:= H . TopBuk;
    Htab[HashLoc] := TopBuk;
    Return H;
End;

Lisp Procedure HashRemFn(S,Htab);    %. remove String if there
 Begin Scalar H,TopBuk,Buk,HashLoc;
    If not StringP S then Return NonStringError(S,'HashRemFn);
    HashLoc :=HashFn(S,Htab);
    TopBuk:=Buk:=Htab[HashLoc];
Loop: 
      If Null Buk then return 0;
      H:=Car Buk; Buk:=cdr Buk;
      If S=ID2String H then goto Rem;
      goto Loop;
Rem:
    Htab[HashLoc] :=DelQ(H,TopBuk);
    SymPak(ID2Int H) := NIL;
    Return H
End;

Lisp Procedure HashMapFn(F,Htab);
 Begin Scalar H,Buk,HashLoc,Hmax;
    Hmax:=UPBV Htab;
    For HashLoc:=0:Hmax do
      <<Buk:=Htab[HashLoc];
        For each H in Buk do Apply(F, List H)>>;
    Return Hmax;
End;


% -------- Generic routines over hash tables
% --- Local Only

Lisp procedure LocalIntern S;                %. Force Into Current Package
 If IDP S then return LocalIntern Id2String S
  else if not StringP S then NonStringError(S,'LocalIntern)
  else if CurrentPackage!* eq NIL
    or CurrentPackage!* eq '\Global then GlobalInstall S
  else begin scalar P,H;
       P:=Get(CurrentPackage!*,'\Package);
       H:=Apply(PackageGetFn P,list S);
       If IDP H then return H;   % already there
       Return Apply(PackagePutFn P,list S);
  End;

Lisp procedure LocalInternP S;                %. Test in Current Package
 If IDP S then LocalInternP ID2String S
  else if not StringP S then NonStringError(S,'LocalInternP)
  else if CurrentPackage!* eq NIL
    or CurrentPackage!* eq '\Global then GlobalLookup S
  else begin scalar P;
       P:=Get(CurrentPackage!*,'\Package);
       Return Apply(PackageGetFn P,list S);
  End;

Lisp procedure LocalRemOb S;                %. Remove from Current Package
 If IDP S then LocalRemob ID2String S
  else if not StringP S then NonStringError(S,'LocalRemob)
  else if CurrentPackage!* eq NIL
    or CurrentPackage!* eq '\Global then GlobalRemove S
  else begin scalar P,H;
       P:=Get(CurrentPackage!*,'\Package);
       Return Apply(PackageRemFn P,list S);
  End;

Lisp procedure LocalMapObl F;                %. Force Into Current Package
 if CurrentPackage!* eq NIL
    or CurrentPackage!* eq '\Global then GlobalMapObl F
  else begin scalar P;
       P:=Get(CurrentPackage!*,'\Package);
       Return Apply(PackageMapFn P,list F);
  End;

% Over Full Tree From CurrentPackage!*

Lisp procedure PathIntern S;                %. Do in Current If not Internd
 If IDP S then PathIntern ID2String S
  else if not StringP S then NonStringError(S,'PathIntern)
  else  if CurrentPackage!* eq NIL
    or CurrentPackage!* eq '\Global then GlobalInstall S  
  else begin scalar H,P;
      If IDP(H:=PathIntern1(S,CurrentPackage!*)) then return H;
      P:=Get(CurrentPackage!*,'\Package);
      Return Apply(PackagePutFn P,list S); % Do it at top level
  end;

Lisp Procedure PathIntern1(S,CurrentPackage!*); % Search Ancestor Chain
  if CurrentPackage!* eq NIL
    or CurrentPackage!* eq '\Global then GlobalLookup S
  else begin scalar P,H;
       P:=Get(CurrentPackage!*,'\Package);
       H:=Apply(PackageGetFn P,list S);
       If IDP H then return H;
       Return PathIntern1(S,PackageFather P); % try ancestor
  End;

Lisp Procedure AlternatePathIntern S;
 begin scalar H;
  H:=PathInternP S;
  If IDP H then return H;
  return LocalIntern S;
 End;

Lisp procedure PathInternP S;                %. TEST if Interned on Path
 PathInternP1(S,CurrentPackage!*);

Lisp Procedure PathInternP1(S,CurrentPackage!*);
 If IDP S then PathInternP1(ID2String S,CurrentPackage!*)
  else if not StringP S then NonStringError(S,'PathInternP)
   else  if CurrentPackage!* eq NIL
    or CurrentPackage!* eq '\Global then GlobalLookup S  
  else begin scalar P,H;
       P:=Get(CurrentPackage!*,'\Package);
       H:=Apply(PackageGetFn P,list S);
       If IDP H then return H;
       return PathInternP1(S,PackageFather P); % try ancestor
  End;

Lisp procedure PathRemOb S;                %. Remove First On Path
 PathRemOb1(S,CurrentPackage!*);

Lisp Procedure PathRemOb1(S,CurrentPackage!*);
 If IDP S then PathRemOb1(ID2String S,CurrentPackage!*)
  else if not StringP S then NonStringError(S,'PathRemob)
  else  if CurrentPackage!* eq  NIL
    or CurrentPackage!* eq '\Global then GlobalRemove S  
  else begin scalar P,H;
       P:=Get(CurrentPackage!*,'\Package);
       H:=Apply(PackageRemFn P,list S);
       If IDP H then return H;
       return PathRemob1(S,PackageFather P); % try ancestor
  End;

Lisp procedure PathMapObl F;                %.  Full path
 PathMapObl1(F,CurrentPackage!*);

Lisp procedure PathMapObl1(F,Pack);
 if Pack eq NIL
    or Pack  eq '\Global then GlobalMapObl F
  else begin scalar P,H;
       P:=Get(Pack,'\Package);
       Apply(PackageMapFn P,list F);
       Return PathMapObl1(F,PackageFather P);
  End;

% ---- Build default Htabs for Bucket Hashed Case

Lisp Procedure \CreateHashedPackage(Name,Father,n);
  Begin Scalar Gf,Pf,Rf,Mf,G;
     G:=Gensym();
     Set(G, Mkvect n);
     Gf:=Gensym();
     Pf:=Gensym();
     Rf:=Gensym();
     Mf:=Gensym();
     PutD(Gf,'Expr,LIST('Lambda,'(S),LIST('HashGetFn,'S,G)));
     PutD(Pf,'Expr,LIST('Lambda,'(S),LIST('HashPutFn,'S,G)));
     PutD(Rf,'Expr,LIST('Lambda,'(S),LIST('HashRemFn,'S,G)));
     PutD(Mf,'Expr,LIST('Lambda,'(F),LIST('HashMapFn,'F,G)));
     Return \CreateRawPackage(Name,Father,Gf,Pf,Rf,Mf);
End;

Lisp Procedure \CreatePackage(Name,Father);
 \CreateHashedPackage(Name,Father,100);

% ------ OutPut Functions

CopyD('OldCprin2,'ChannelPrin2);
CopyD('OldCprin1,'ChannelPrin1);
%/ Take Channel and Itm

Lisp Procedure NewCprin1(Channel,Itm);
If IDP Itm then
 Begin Scalar IDN,PN;
    IDN:=ID2Int Itm;
    PN:=SymPak IDN;
    If IDP PN and PN  then
      <<NewCprin1(Channel,PN);ChannelWriteChar(Channel,PackageCharacter!*)>>;
    OldCprin1(Channel,Itm);
 End
else OldCprin1(Channel,Itm);

Lisp Procedure NewCprin2(Channel,Itm);
If IDP Itm then
 Begin Scalar IDN,PN;
    IDN:=ID2Int Itm;
    PN:=SymPak IDN;
    If IDP PN and PN then
      <<NewCprin2(Channel,PN);ChannelWriteChar(Channel,PackageCharacter!*)>>;
    OldCprin2(Channel,Itm);
 End
else
    OldCprin2(Channel,Itm);

% ----- A simple Demo ---------------

Procedure redef;
Begin
 CopyD('Intern,'PathIntern );
 CopyD('InternP,'PathInternP );
 CopyD('RemOb ,'PathRemOb );
 CopyD('MapObl ,'PathMapObl);
 CopyD('ChannelPrin1,'NewCPrin1); 
 CopyD('ChannelPrin2,'NewCPrin2);
end;

CopyD('CachedGlobalLookup,'GlobalLookup);

Procedure GlobalLookup S;
 <<LastLookedUp:=NIL;          %/ Fix Cache Bug that always said YES
   CachedGlobalLookup S>>;

CopyD('NonCopyInstall,'GlobalInstall); % Some Bug in this too, clobers string
Procedure GlobalInstall(S);
 NonCopyInstall CopyString S;

Redef();

\CreatePackage('\P1,'\Global);
\CreatePackage('\P2,'\Global);

end;


REDUCE Historical
REDUCE Sourceforge Project | Historical SVN Repository | GitHub Mirror | SourceHut Mirror | NotABug Mirror | Chisel Mirror | Chisel RSS ]