File psl-1983/3-1/kernel/easy-sl.red artifact 642f7c1834 part of check-in f16ac07139


%
% EASY-SL.RED - Standard Lisp functions with easy Standard Lisp definitions
% 
% Author:      Eric Benson
%	       Symbolic Computation Group
%              Computer Science Dept.
%              University of Utah
% Date:        17 August 1981
% Copyright (c) 1981 University of Utah
%

%  <PSL.KERNEL>EASY-SL.RED.3, 17-Sep-82 16:16:58, Edit by BENSON
%  Added ChannelPrint
%  <PSL.INTERP>EASY-SL.RED.4, 13-Aug-82 14:14:49, Edit by BENSON
%  Changed nice recursive Append to ugly iterative definition
%  <PSL.INTERP>EASY-SL.RED.13,  8-Feb-82 17:43:07, Edit by BENSON
%  Made SetQ take multiple arguments
%  <PSL.INTERP>EASY-SL.RED.7, 18-Jan-82 17:30:14, Edit by BENSON
%  Added Max2 and Min2
%  <PSL.INTERP>EASY-SL.RED.6, 15-Jan-82 14:54:36, Edit by BENSON
%  Changed DE, DF, DM, DN from Fexprs to Macros

% This file contains only functions found in the Standard Lisp report which
% can be easily and efficiently defined in terms of other Standard Lisp
% functions.  It does not include primitive functions which are handled
% specially by the compiler, such as EQ.

% Many NULL tests in these functions have been replaced with not PairP tests,
% so that they will be safer.

CompileTime flag('(EvAnd1), 'InternalFunction);

% Section 3.1 -- Elementary predicates

lisp procedure Atom U;			%. is U a non pair?
    not PairP U;

lisp procedure ConstantP U;		%. is Eval U eq U by definition?
    not PairP U and not IDP U;

lisp procedure Null U;			%. is U eq NIL?
    U eq NIL;

lisp procedure NumberP U;		%. is U a number of any kind?
    FixP U or FloatP U;

lisp procedure Expt(X, N);
begin scalar Result;
    if not IntP N or not NumberP X then return
	ContError(99, "Illegal arguments to Expt", X ** N);
    Result := 1;
    if N > 0 then
	for I := 1 step 1 until N do Result := Result * X
    else if N < 0 then
	for I := -1 step -1 until N do Result := Result / X;
    return Result;
end;

% MinusP, OneP and ZeroP are in ARITHMETIC.RED
% FixP is defined in OTHERS-SL.RED

% Section 3.2 -- Functions on Dotted-Pairs

% composites of CAR and CDR are found in CARCDR.RED

fexpr procedure List U;			%. construct list of arguments
    EvLis U;


% section 3.5 -- Function definition

macro procedure DE U;			%. Terse syntax for PutD call for EXPR
    list('PutD, MkQuote cadr U,
		'(QUOTE EXPR),
		list('FUNCTION, ('LAMBDA . cddr U)));

macro procedure DF U;			%. Terse syntax for PutD call for FEXPR
    list('PutD, MkQuote cadr U,
		'(QUOTE FEXPR),
		list('FUNCTION, ('LAMBDA . cddr U)));

macro procedure DM U;			%. Terse syntax for PutD call for MACRO
    list('PutD, MkQuote cadr U,
		'(QUOTE MACRO),
		list('FUNCTION, ('LAMBDA . cddr U)));

macro procedure DN U;			%. Terse syntax for PutD call for NEXPR
    list('PutD, MkQuote cadr U,
		'(QUOTE NEXPR),
		list('FUNCTION, ('LAMBDA . cddr U)));


% Section 3.6 -- Variables and bindings

fexpr procedure SetQ U;			%. Standard named variable assignment
%
% Extended from SL Report to be Common Lisp compatible
% (setq foo 1 bar 2 ...) is permitted
%
begin scalar V, W;
    while U do
    <<  W := cdr U;
	Set(car U, V := Eval car W);
	U := cdr W >>;
    return V;
end;

% Section 3.7 -- Program feature functions

lisp procedure Prog2(U, V);		%. Return second argument
    V;

fexpr procedure ProgN U;		%. Sequential evaluation, return last
    EvProgN U;

StartupTime put('PROGN, 'TYPE, 'FEXPR);

lisp procedure EvProgN U;		%. EXPR support for ProgN, Eval, Cond
    if PairP U then
    <<  while PairP cdr U do
	<<  Eval car U;
	    U := cdr U >>;
	Eval car U >>
    else NIL;

% Section 3.10 -- Boolean functions and conditionals

fexpr procedure And U;			%. Sequentially evaluate until NIL
    EvAnd U;

lisp procedure EvAnd U;			%. EXPR support for And
    if not PairP U then T else EvAnd1 U;

lisp procedure EvAnd1 U;		% Auxiliary function for EvAnd
    if not PairP cdr U then Eval car U
    else if not Eval car U then NIL
    else EvAnd1 cdr U;

fexpr procedure OR U;			%. sequentially evaluate until non-NIL
    EvOr U;

lisp procedure EvOr U;			%. EXPR support for Or
    PairP U and (Eval car U or EvOr cdr U);

fexpr procedure Cond U;			%. Conditional evaluation construct
    EvCond U;

lisp procedure EvCond U;		%. EXPR support for Cond
%
% Extended from Standard Lisp definition to allow no consequent (antecedent is
% returned), or multiple consequent (implicit progn).
%
begin scalar CondForm, Antecedent, Result;
    return if not PairP U then NIL
    else
    <<  CondForm := car U;
	U := cdr U;
	Antecedent := if PairP CondForm then car CondForm else CondForm;
	if not (Result := Eval Antecedent) then
	    EvCond U
	else if not PairP CondForm or not PairP cdr CondForm then
	    Result
	else
	    EvProgN cdr CondForm >>;
end;

lisp procedure Not U;			%. Equivalent to NULL
    null U;


% Section 3.11 -- Arithmetic functions

lisp procedure Abs U;			%. Absolute value of number
    if MinusP U then -U else U;

lisp procedure Divide(U, V);		%. dotted pair remainder and quotient
    if ZeroP V then
	ContError(99, "Attempt to divide by 0 in DIVIDE", Divide(U, V))
    else
	Quotient(U, V) . Remainder(U, V);

macro procedure Max U;			%. numeric maximum of several arguments
    RobustExpand(cdr U, 'Max2, 0);	% should probably be -infinity

lisp procedure Max2(U, V);		%. maximum of 2 arguments
    if U < V then V else U;

macro procedure Min U;			%. numeric minimum of several arguments
    RobustExpand(cdr U, 'Min2, 0);	% should probably be +infinity

lisp procedure Min2(U, V);		%. minimum of 2 arguments
    if U > V then V else U;

macro procedure Plus U;			%. addition of several arguments
    RobustExpand(cdr U, 'Plus2, 0);

macro procedure Times U;		%. multiplication of several arguments
    RobustExpand(cdr U, 'Times2, 1);


% Section 3.12 -- MAP Composite functions

lisp procedure Map(L, Fn);		%. for each X on L do Fn(X);
    while PairP L do
    <<  Apply(Fn, list L);
	L := cdr L >>;

lisp procedure MapC(L, Fn);		%. for each X in L do Fn(X);
    while PairP L do
    <<  Apply(Fn, list car L);
	L := cdr L >>;

lisp procedure MapCan(L, Fn);		%. for each X in L conc Fn(X);
    if not PairP L then NIL
    else NConc(Apply(Fn, list car L), MapCan(cdr L, Fn));

lisp procedure MapCon(L, Fn);		%. for each X on L conc Fn(X);
    if not PairP L then NIL
    else NConc(Apply(Fn, list L), MapCon(cdr L, Fn));

lisp procedure MapCar(L, Fn);		%. for each X in L collect Fn(X);
    if not PairP L then NIL
    else Apply(Fn, list car L) . MapCar(cdr L, Fn);

lisp procedure MapList(L, Fn);		%. for each X on L collect Fn(X);
    if not PairP L then NIL
    else Apply(Fn, list L) . MapList(cdr L, Fn);


% Section 3.13 -- Composite functions

lisp procedure Append(U, V);		%. Combine 2 lists
    if not PairP U then V else begin scalar U1, U2;
	U1 := U2 := car U . NIL;
	U := cdr U;
	while PairP U do
	<<  RplacD(U2, car U . NIL);
	    U := cdr U;
	    U2 := cdr U2 >>;
	RplacD(U2, V);
	return U1;
    end;

%
% These A-list functions differ from the Standard Lisp Report in that
% poorly formed A-lists (non-pair entries) are not signalled as an error,
% rather the entries are ignored.  This is because some data structures
% (such as property lists) use atom entries for other purposes.
%

lisp procedure Assoc(U, V);		%. Return first (U . xxx) in V, or NIL
    if not PairP V then NIL
    else if PairP car V and U = caar V then car V
    else Assoc(U, cdr V);

lisp procedure Sassoc(U, V, Fn);	%. Return first (U . xxx) in V, or Fn()
    if not PairP V then Apply(Fn, NIL)
    else if PairP car V and U = caar V then car V
    else Sassoc(U, cdr V, Fn);

lisp procedure Pair(U, V);		%. For each X,Y in U,V collect (X . Y)
    if PairP U and PairP V then (car U . car V) . Pair(cdr U, cdr V)
    else if PairP U or PairP V then
	StdError "Different length lists in PAIR"
    else NIL;

lisp procedure SubLis(X, Y);		%. Substitution in Y by A-list X
    if not PairP X then Y
    else begin scalar U;
	U := Assoc(Y, X);
	return if PairP U then cdr U
	else if not PairP Y then Y
	else SubLis(X, car Y) . SubLis(X, cdr Y);
    end;


lisp procedure DefList(DList, Indicator);	%. PUT many IDs, same indicator
    if not PairP DList then NIL else
    <<  put(caar DList, Indicator, cadar DList);
	caar DList >> . DefList(cdr DList, Indicator);

lisp procedure Delete(U, V);		%. Remove first top-level U in V
    if not PairP V then V
    else if car V = U then cdr V
    else car V . Delete(U, cdr V);

%  DIGIT, LENGTH and LITER are optimized, don't use SL Report version

lisp procedure Member(U, V);		%. Find U in V
    if not PairP V then NIL
    else if U = car V then V
    else U Member cdr V;

lisp procedure MemQ(U, V);		% EQ version of Member
    if not PairP V then NIL
    else if U eq car V then V
    else U MemQ cdr V;

lisp procedure NConc(U, V);		%. Destructive version of Append
begin scalar W;
    if not PairP U then return V;
    W := U;
    while PairP cdr W do W := cdr W;
    RplacD(W, V);
    return U;
end;

lisp procedure Reverse U;		%. Top-level reverse of list
begin scalar V;
    while PairP U do
    <<  V := car U . V;
	U := cdr U >>;
    return V;
end;

lisp procedure Subst(A, X, L);		%. Replace every X in L with A
    if null L then NIL
    else if X = L then A
    else if null PairP L then L
    else Subst(A, X, car L) . Subst(A, X, cdr L);

lisp procedure EvLis U;			%. For each X in U collect Eval X
    if not PairP U then NIL
    else Eval car U . EvLis cdr U;

lisp procedure RobustExpand(L, Fn, EmptyCase); %. Expand + arg for empty list
    if null L then EmptyCase else Expand(L, Fn);

lisp procedure Expand(L, Fn);		%. L = (a b c) --> (Fn a (Fn b c))
    if not PairP L then L
    else if not PairP cdr L then car L
    else list(Fn, car L, Expand(cdr L, Fn));

fexpr procedure Quote U;		%. Return unevaluated argument
    car U;

StartupTime put('QUOTE, 'TYPE, 'FEXPR);	% needed to run from scratch

fexpr procedure Function U;		%. Same as Quote in this version
    car U;


% Section 3.15 -- Input and Output

lisp procedure ChannelPrint(C, U);	%. Display U and terminate line
<<  ChannelPrin1(C, U);
    ChannelTerPri C;
    U >>;

lisp procedure Print U;			%. Display U and terminate line
    ChannelPrint(OUT!*, U);

End;


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