Artifact 642f7c1834ca5f43eacb8cbe0ee2349afdedd6418f37a40bdf8870ecd4be4e6f:

• File psl-1983/3-1/kernel/easy-sl.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: 10170) [annotate] [blame] [check-ins using] [more...]

• File psl-1983/kernel/easy-sl.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: 10170) [annotate] [blame] [check-ins using]

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