reduce-historical/psl-1983/kernel/easy-non-sl.red

%
% EASY-NON-SL.RED - Commonly used Non-Standard Lisp functions
% 
% Author:      Eric Benson
%	       Symbolic Computation Group
%              Computer Science Dept.
%              University of Utah
% Date:        18 August 1981
% Copyright (c) 1981 University of Utah
%

%  <PSL.KERNEL>EASY-NON-SL.RED.2, 17-Sep-82 16:10:18, Edit by BENSON
%  Added ChannelPrin2T, ChannelSpaces, ChannelTab, ChannelSpaces2
%  <PSL.INTERP>EASY-NON-SL.RED.7,  9-Jul-82 12:46:43, Edit by BENSON
%  Changed NTH to improve error reporting, using DoPNTH
%  <PSL.INTERP>EASY-NON-SL.RED.2, 19-Apr-82 23:05:35, Edit by BENSON
%  Changed order of tests in PNTH
%  <PSL.INTERP>EASY-NON-SL.RED.20, 23-Feb-82 21:36:36, Edit by BENSON
%  Added NE (not eq)
%  <PSL.INTERP>EASY-NON-SL.RED.19, 16-Feb-82 22:30:33, Edit by BENSON
%  made NEQ GEQ and LEQ back into EXPRs
%  <PSL.INTERP>EASY-NON-SL.RED.16, 15-Feb-82 18:01:14, Edit by BENSON
%  Made NEQ GEQ and LEQ into macros
%  <PSL.INTERP>EASY-NON-SL.RED.12, 18-Jan-82 12:28:13, Edit by BENSON
%  Added NexprP

CompileTime flag('(DelqIP1 DeletIP1 SubstIP1 DelAscIP1 DelAtQIP1 DoPNTH),
		 'InternalFunction);

% predicates

expr procedure NEQ(U, V);	%. not EQUAL (should be changed to not EQ)
    not(U = V);

expr procedure NE(U, V);		%. not EQ
    not(U eq V);

expr procedure GEQ(U, V);		%. greater than or equal to
    not(U < V);

expr procedure LEQ(U, V);		%. less than or equal to
    not(U > V);

lisp procedure EqCar(U, V);		%. car U eq V
    PairP U and car U eq V;

lisp procedure ExprP U;			%. Is U an EXPR?
    EqCar(U, 'LAMBDA) or CodeP U or EqCar(GetD U, 'EXPR);

lisp procedure MacroP U;		%. Is U a MACRO?
    EqCar(GetD U, 'MACRO);

lisp procedure FexprP U;		%. Is U an FEXPR?
    EqCar(GetD U, 'FEXPR);

lisp procedure NexprP U;		%. Is U an NEXPR?
    EqCar(GetD U, 'NEXPR);

% Function definition

lisp procedure CopyD(New, Old);		%. FunDef New := FunDef Old;
%
% CopyD(New:id, Old:id):id
% -----------------------
% Type: EVAL, SPREAD
% The function body and type for New become the same as Old. If no
% definition exists for Old, the error
%
% ***** `Old' has no definition in CopyD
%
% occurs.  New is returned.
%
begin scalar OldDef;
    OldDef := GetD Old;
    if PairP OldDef then
	PutD(New, car OldDef, cdr OldDef)
    else
        StdError BldMsg("%r has no definition in CopyD", Old);
    return New;
end;

% Numerical functions

lisp procedure Recip N;			%. Floating point reciprocal
    1.0 / N;

% Commonly used constructors

lisp procedure MkQuote U;		%. Eval MkQuote U eq U
    list('QUOTE, U);


% Nicer names to access parts of a list

macro procedure First U;		%. First element of a list
    'CAR . cdr U;

macro procedure Second U;		%. Second element of a list
    'CADR . cdr U;

macro procedure Third U;		%. Third element of a list
    'CADDR . cdr U;

macro procedure Fourth U;		%. Fourth element of a list
    'CADDDR . cdr U;

macro procedure Rest U;			%. Tail of a list
    'CDR . cdr U;


% Destructive and EQ versions of Standard Lisp functions

lisp procedure ReversIP U;	%. Destructive REVERSE (REVERSe In Place)
begin scalar X,Y; 
    while PairP U do
    <<  X := cdr U;
	Y := RplacD(U, Y);
	U := X >>; 
    return Y
end;

lisp procedure SubstIP1(A, X, L);	% Auxiliary function for SubstIP
<<  if X = car L then RplacA(L, A)
    else if PairP car L then SubstIP(A, X, car L);
    if PairP cdr L then SubstIP(A, X, cdr L) >>;

lisp procedure SubstIP(A, X, L);	%. Destructive version of Subst
    if null L then NIL
    else if X = L then A
    else if not PairP L then L
    else
    <<  SubstIP1(A, X, L);
	L >>;

lisp procedure DeletIP1(U, V);		% Auxiliary function for DeletIP
    if PairP cdr V then
	if U = cadr V then RplacD(V, cddr V)
	else DeletIP1(U, cdr V);

lisp procedure DeletIP(U, V);		%. Destructive DELETE
    if not PairP V then V
    else if U = car V then cdr V
    else
    <<  DeletIP1(U, V);
	V >>;

lisp procedure DelQ(U, V);		%. EQ version of DELETE
    if not PairP V then V
    else if car V eq U then cdr V
    else car V . DelQ(U, cdr V);

lisp procedure Del(F, U, V); %. Generalized Delete, F is comparison function
    if not PairP V then V
    else if Apply(F, list(car V, U)) then cdr V
    else car V . Del(F, U, cdr V);

lisp procedure DelqIP1(U, V);		% Auxiliary function for DelqIP
    if PairP cdr V then
	if U eq cadr V then RplacD(V, cddr V)
	else DelqIP1(U, cdr V);

lisp procedure DelqIP(U, V);		%. Destructive DELQ
    if not PairP V then V
    else if U eq car V then cdr V
    else
    <<  DelqIP1(U, V);
	V >>;

lisp procedure Atsoc(U, V);		%. EQ version of ASSOC
    if not PairP V then NIL
    else if PairP car V and U eq caar V then car V
    else Atsoc(U, cdr V);

lisp procedure Ass(F, U, V); %. Generalized Assoc, F is comparison function
%
% Not to be confused with Elbow
%
    if not PairP V then NIL
    else if PairP car V and Apply(F, list(U, caar V)) then car V
    else Ass(F, U, cdr V);

lisp procedure Mem(F, U, V); %. Generalized Member, F is comparison function
    if not PairP V then NIL
    else if Apply(F, list(U, car V)) then V
    else Mem(F, U, cdr V);

lisp procedure RAssoc(U, V);	%. Reverse Assoc, compare with cdr of entry
    if not PairP V then NIL
    else if PairP car V and U = cdar V then car V
    else RAssoc(U, cdr V);

lisp procedure DelAsc(U, V);		%. Remove first (U . xxx) from V
    if not PairP V then NIL
    else if PairP car V and U = caar V then cdr V
    else car V . DelAsc(U, cdr V);

lisp procedure DelAscIP1(U, V);		% Auxiliary function for DelAscIP
    if PairP cdr V then
	if PairP cadr V and U = caadr V then
	    RplacD(V, cddr V)
	else DelAscIP1(U, cdr V);

lisp procedure DelAscIP(U, V);		%. Destructive DelAsc
    if not PairP V then NIL
    else if PairP car V and U = caar V then cdr V
    else
    <<  DelAscIP1(U, V);
	V >>;

lisp procedure DelAtQ(U, V);		%. EQ version of DELASC
   if not PairP V then NIL
   else if EqCar(car V, U) then cdr V
   else car V . DelAtQ(U, cdr V);

lisp procedure DelAtQIP1(U, V);		% Auxiliary function for DelAtQIP
    if PairP cdr V then
	if PairP cadr V and U eq caadr V then
	    RplacD(V, cddr V)
	else DelAtQIP1(U, cdr V);

lisp procedure DelAtQIP(U, V);		%. Destructive DelAtQ
    if not PairP V then NIL
    else if PairP car V and U eq caar V then cdr V
    else
    <<  DelAtQIP1(U, V);
	V >>;

lisp procedure SublA(U,V);	%. EQ version of SubLis, replaces atoms only
begin scalar X;
    return if not PairP U or null V then V
    else if atom V then
	if (X := Atsoc(V, U)) then cdr X else V
    else SublA(U, car V) . SublA(U, cdr V)
end;


lisp procedure RplacW(A, B);		%. RePLACe Whole pair
    if PairP A then
	if PairP B then
	    RplacA(RplacD(A,
			  cdr B),
		   car B)
	else
	    NonPairError(B, 'RplacW)
    else
	NonPairError(A, 'RPlacW);

lisp procedure LastCar X;		%. last element of list
    if atom X then X else car LastPair X;

lisp procedure LastPair X;		%. last pair of list
    if atom X or atom cdr X then X else LastPair cdr X;

lisp procedure Copy U;			%. copy all pairs in S-Expr
%
% See also TotalCopy in COPIERS.RED
%
    if PairP U then Copy car U . Copy cdr U else U;	% blows up if circular


lisp procedure NTH(U, N);		%. N-th element of list
(lambda(X);
    if PairP X then car X else RangeError(U, N, 'NTH))(DoPNTH(U, N));

lisp procedure DoPNTH(U, N);
    if N = 1 or not PairP U then U
    else DoPNTH(cdr U, N - 1);

lisp procedure PNTH(U, N);		%. Pointer to N-th element of list
    if N = 1 then U
    else if not PairP U then
	RangeError(U, N, 'PNTH)
    else PNTH(cdr U, N - 1);

lisp procedure AConc(U, V);	%. destructively add element V to the tail of U
    NConc(U, list V);

lisp procedure TConc(Ptr, Elem);	%. AConc maintaining pointer to end
%
% ACONC with pointer to end of list
% Ptr is (list . last CDR of list)
% returns updated Ptr
% Ptr should be initialized to (NIL . NIL) before calling the first time
%
<<  Elem := list Elem;
    if not PairP Ptr then	 % if PTR not initialized, return starting ptr
	Elem . Elem
    else if null cdr Ptr then	 % Nothing in the list yet
	RplacA(RplacD(Ptr, Elem), Elem)
    else
    <<  RplacD(cdr Ptr, Elem);
	RplacD(Ptr, Elem) >> >>;

lisp procedure LConc(Ptr, Lst);		%. NConc maintaining pointer to end
%
% NCONC with pointer to end of list
% Ptr is (list . last CDR of list)
% returns updated Ptr
% Ptr should be initialized to NIL . NIL before calling the first time
%
    if null Lst then Ptr
    else if atom Ptr then	 % if PTR not initialized, return starting ptr
	Lst . LastPair Lst
    else if null cdr Ptr then	 % Nothing in the list yet
	RplacA(RplacD(Ptr, LastPair Lst), Lst)
    else
    <<  RplacD(cdr Ptr, Lst);
	RplacD(Ptr, LastPair Lst) >>;


% MAP functions of 2 arguments

lisp procedure Map2(L, M, Fn);		%. for each X, Y on L, M do Fn(X, Y);
<<  while PairP L and PairP M do
    <<  Apply(Fn, list(L, M));
	L := cdr L;
	M := cdr M >>;
    if PairP L or PairP M then
	StdError "Different length lists in MAP2"
    else NIL >>;

lisp procedure MapC2(L, M, Fn);		%. for each X, Y in L, M do Fn(X, Y);
<<  while PairP L and PairP M do
    <<  Apply(Fn, list(car L, car M));
	L := cdr L;
	M := cdr M >>;
    if PairP L or PairP M then
	StdError "Different length lists in MAPC2"
    else NIL >>;

% Printing functions

lisp procedure ChannelPrin2T(C, U);		%. Prin2 and TerPri
<<  ChannelPrin2(C, U);
    ChannelTerPri C;
    U >>;

lisp procedure Prin2T U;		%. Prin2 and TerPri
    ChannelPrin2T(OUT!*, U);

lisp procedure ChannelSpaces(C, N);		%. Prin2 N spaces
   for I := 1 step 1 until N do ChannelWriteChar(C, char BLANK);

lisp procedure Spaces N;		%. Prin2 N spaces
    ChannelSpaces(OUT!*, N);

lisp procedure ChannelTAB(Chn, N);	%. Spaces to column N
begin scalar M;
    M := ChannelPosn Chn;
    if N < M then
    <<  ChannelTerPri Chn;
	M := 0 >>;
    ChannelSpaces(Chn, N - M);
end;

lisp procedure TAB N;			%. Spaces to column N
    ChannelTAB(OUT!*, N);

if_system(Dec20, <<
lap '((!*entry FileP expr 1)
	(!*MOVE (REG 1) (REG 2))
	(hrli 2 8#010700)		% make a byte pointer
	(hrlzi 1 2#001000000000000001)	% gj%old + gj%sht
	(gtjfn)
	 (jrst NotFile)
	(rljfn)				% release it
	(jfcl)
	(!*MOVE (QUOTE T) (REG 1))
	(!*EXIT 0)
NotFile
	(!*MOVE (QUOTE NIL) (REG 1))
	(!*EXIT 0)
); >>, <<
lisp procedure FileP F;			%. is F an existing file?
%
% This could be done more efficiently in a much more system-dependent way,
% but efficiency probably doesn't matter too much here.
%
    if PairP(F := ErrorSet(list('OPEN, MkQuote F, '(QUOTE INPUT)), NIL, NIL))
    then
    <<  Close car F;
	T >>
    else NIL; >>);

% This doesn't belong anywhere and will be eliminated soon

lisp procedure PutC(Name, Ind, Exp);	%. Used by RLISP to define SMACROs
<<  put(Name, Ind, Exp);
    Name >>;

LoadTime <<
    PutD('Spaces2, 'EXPR, cdr GetD 'TAB);	% For compatibility
    PutD('ChannelSpaces2, 'EXPR, cdr GetD 'ChannelTAB);
>>;

END;