Artifact 9028a22a9db32d31fda7bb242b276b3dbb9f23290abddf8ea27303c86de90e29:

• File psl-1983/3-1/util/narith.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: 9675) [annotate] [blame] [check-ins using] [more...]

• File psl-1983/util/narith.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: 9675) [annotate] [blame] [check-ins using]

%
% ARITHMETIC.RED - Generic arithmetic routines for PSL
% 	           New model, much less hairy lap

% Author:      Eric Benson
%              Symbolic Computation Group
%              Computer Science Dept.
%              University of Utah
% Date:        9 August 1982
% Copyright (c) 1982 University of Utah
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Note: Loading BIGFACE is supposed to define (or redefine)
%       the functions:
%		ISINUM
%		StaticIntBig
%		StaticBigFloat
%		Sys2Int
%		Int2Sys
%		FloatFix
%
% Mods by MLG, 21 dec 1982
% 	Take off INTERNALFUNCTION form FLOATFIX and StaticFloatBig
% 	Change IsInum to be a procedure
%       Change names of FAKE and SFL to xxxxLOC

CompileTime << % Some aliases
	Fluid '(ArithArgLoc StaticFloatLoc);
        put('ArithArg, 'NewNam, '(LispVar ArithArgLoc));
        put('StaticFloat, 'NewNam, '(LispVar StaticFloatLoc));
>>;

LoadTime <<     % Allocate Physical Space
	ArithArgLoc := GtWArray 2;
        StaticFloatLoc := GtWArray 3;
>>;

on Syslisp;

%internal WArray ArithArg[1], StaticFloat = [1, 0, 0];

CompileTime <<

flag('(Coerce2 FloatPlus2 FloatDifference FloatTimes2
       FloatQuotient FloatGreaterP FloatLessP IntFloat
       NonInteger2Error NonNumber1Error
), 'InternalFunction);

syslsp macro procedure IsInumMac U;
<<  U := second U;
    if atom U then
	list('eq, list('SignedField, U, '(ISub1 (WConst InfStartingBit)),
					'(IAdd1 (WConst InfBitLength))), U)
    else
    list('(lambda (X) (eq (SignedField X
				       (ISub1 (WConst InfStartingBit))
				       (IAdd1 (WConst InfBitLength)))
			  X)),
	 U) >>;

expr procedure NameGen Name;
    Intern Concat(ID2String Name, StringGensym());

macro procedure DefArith2Entry U;
begin scalar generic, wgen, fgen, bgen, hardgen, gen0;
    U :=rest U;
    generic := first U;
    U := rest U;
    wgen := first U;
    U := rest U;
    fgen := first U;
    U := rest U;
    bgen := first U;
    hardgen := NameGen generic;
    gen0 := NameGen generic;
    Flag1(hardgen, 'InternalFunction);
    Flag1(gen0, 'InternalFunction);
    return SublA(Pair('(GENERIC WGEN FGEN BGEN HARDGEN GEN0),
		      list(generic, wgen, fgen, bgen, hardgen, gen0)),
		 quote <<

expr procedure GENERIC(x,y);
    if intp x and intp y then GEN0(x, y, WGEN(x, y)) else HARDGEN(x, y);

expr procedure GEN0(x, y, z);
    if isinum z then z else HARDGEN(x, y);

expr procedure HARDGEN(x, y);
    case Coerce2(x, y, 'GENERIC) of
	POSINT:
	    Sys2Int WGEN(WGetV(ArithArg, 0), WGetV(ArithArg, 1));
	FLTN:
	    FGEN(WGetV(ArithArg, 0), WGetV(ArithArg, 1));
	BIGN:
	    BGEN(WGetV(ArithArg, 0), WGetV(ArithArg, 1));
    end;

>>);
end;

macro procedure DefArithPred2Entry U;
begin scalar generic, wgen, fgen, bgen, hardgen, gen0;
    U :=rest U;
    generic := first U;
    U := rest U;
    wgen := first U;
    U := rest U;
    fgen := first U;
    U := rest U;
    bgen := first U;
    hardgen := NameGen generic;
    gen0 := NameGen generic;
    Flag1(hardgen, 'InternalFunction);
    Flag1(gen0, 'InternalFunction);
    return SublA(Pair('(GENERIC WGEN FGEN BGEN HARDGEN GEN0),
		      list(generic, wgen, fgen, bgen, hardgen, gen0)),
		 quote <<

expr procedure GENERIC(x,y);
    if intp x and intp y then WGEN(x, y) else HARDGEN(x, y);

expr procedure HARDGEN(x, y);
    case Coerce2(x, y, 'GENERIC) of
	POSINT:
	    WGEN(WGetV(ArithArg, 0), WGetV(ArithArg, 1));
	FLTN:
	    FGEN(WGetV(ArithArg, 0), WGetV(ArithArg, 1));
	BIGN:
	    BGEN(WGetV(ArithArg, 0), WGetV(ArithArg, 1));
    end;

>>);
end;

macro procedure DefInt2Entry U;
begin scalar generic, wgen, bgen, hardgen, gen0;
    U :=rest U;
    generic := first U;
    U := rest U;
    wgen := first U;
    U := rest U;
    bgen := first U;
    hardgen := NameGen generic;
    gen0 := NameGen generic;
    Flag1(hardgen, 'InternalFunction);
    Flag1(gen0, 'InternalFunction);
    return SublA(Pair('(GENERIC WGEN BGEN HARDGEN GEN0),
		      list(generic, wgen, bgen, hardgen, gen0)),
		 quote <<

expr procedure GENERIC(x,y);
    if intp x and intp y then GEN0(x, y, WGEN(x, y)) else HARDGEN(x, y);

expr procedure GEN0(x, y, z);
    if isinum z then z else HARDGEN(x, y);

expr procedure HARDGEN(x, y);
    case Coerce2(x, y, 'GENERIC) of
	POSINT:
	    Sys2Int WGEN(WGetV(ArithArg, 0), WGetV(ArithArg, 1));
	FLTN:
	    NonInteger2Error(x, y, 'GENERIC);
	BIGN:
	    BGEN(WGetV(ArithArg, 0), WGetV(ArithArg, 1));
    end;

>>);
end;

macro procedure DefArith1Entry U;
begin scalar generic, wgen, fgen, bgen, hardgen, gen0;
    U :=rest U;
    generic := first U;
    U := rest U;
    wgen := first U;
    U := rest U;
    fgen := first U;
    U := rest U;
    bgen := first U;
    hardgen := NameGen generic;
    gen0 := NameGen generic;
    Flag1(hardgen, 'InternalFunction);
    Flag1(gen0, 'InternalFunction);
    return SublA(Pair('(GENERIC WGEN FGEN BGEN HARDGEN GEN0),
		      list(generic, wgen, fgen, bgen, hardgen, gen0)),
		 quote <<

expr procedure GENERIC x;
    if intp x then GEN0(x, WGEN x) else HARDGEN x;

expr procedure GEN0(x, z);
    if isinum z then z else HARDGEN x;

expr procedure HARDGEN x;
    case Tag x of
	NEGINT, POSINT:
	    Sys2Int WGEN x;
	FIXN:
	    Sys2Int WGEN FixVal FixInf x;
	FLTN:
	    FGEN x;
	BIGN:
	    BGEN x;
	default:
	    NonNumber1Error(x, 'GENERIC);
    end;

>>);
end;

macro procedure DefArithPred1Entry U;
begin scalar generic, wgen, fgen, bgen, hardgen, gen0;
    U :=rest U;
    generic := first U;
    U := rest U;
    wgen := first U;
    U := rest U;
    fgen := first U;
    U := rest U;
    bgen := first U;
    hardgen := NameGen generic;
    gen0 := NameGen generic;
    Flag1(hardgen, 'InternalFunction);
    Flag1(gen0, 'InternalFunction);
    return SublA(Pair('(GENERIC WGEN FGEN BGEN HARDGEN GEN0),
		      list(generic, wgen, fgen, bgen, hardgen, gen0)),
		 quote <<

expr procedure GENERIC x;
    if intp x then WGEN x else HARDGEN x;

expr procedure HARDGEN x;
    case Tag x of
	NEGINT, POSINT:
	    WGEN x;
	FIXN:
	    WGEN FixVal FixInf x;
	FLTN:
	    FGEN x;
	BIGN:
	    BGEN x;
	default:
	    NIL;
    end;

>>);
end;

smacro procedure DefFloatEntry(Name, Prim);
procedure Name(x, y);
begin scalar f;
    f := GtFLTN();
    Prim(FloatBase f, FloatBase FltInf x,
		      FloatBase FltInf y);
    return MkFLTN f;
end;


>>;

procedure Coerce2(X, Y, F);
%
% Returns type tag of strongest type and sets ArithArg[0] to be coerced X
% and ArithArg[1] to coerced Y.
%
begin scalar T1, T2, P, C;
    T1 := Tag X;
    case T1 of
	NEGINT:
	    T1 := POSINT;
	FIXN:
	<<  T1 := POSINT;
	    X := FixVal FixInf X >>;
    end;
    T2 := Tag Y;
    case T2 of
	NEGINT:
	    T2 := POSINT;
	FIXN:
	<<  T2 := POSINT;
	    Y := FixVal FixInf Y >>;
    end;
    ArithArg[0] := X;
    ArithArg[1] := Y;
    if T1 eq T2 then return T1;		% no coercion to be done
    if T1 < T2 then			% coerce first arg to second
    <<  P := &ArithArg[0];		% P points to first (to be coerced)
	C := T2;			% swap T1 and T2
	T2 := T1;
	T1 := C >>
    else
	P := &ArithArg[1];		% P points to second
    if T1 > FLTN then return
	ContinuableError(99, "Non-numeric argument in arithmetic",
			     list(F, MkQuote X, MkQuote Y));
    case T1 of
	FLTN:
	    case T2 of
		POSINT:
		    @P := StaticIntFloat @P;
		BIGN:
		    @P := StaticBigFloat @P;
	    end;
	BIGN:
	    @P := StaticIntBig @P;	% @P must be inum
    end;
    return T1;
end;

procedure StaticIntFloat X;
<<  !*WFloat(&StaticFloat[1], X);
    MkFLTN &StaticFloat[0] >>;

procedure NonInteger2Error(X, Y, F);
    ContinuableError(99, "Non-integer argument in arithmetic",
			 list(F, MkQuote X, MkQuote Y));

procedure NonNumber1Error(X, F);
    ContinuableError(99, "Non-numeric argument in arithmetic",
			 list(F, MkQuote X));


DefArith2Entry(Plus2, WPlus2, FloatPlus2, BigPlus2);

DefFloatEntry(FloatPlus2, !*FPlus2);

DefArith2Entry(Difference, WDifference, FloatDifference, BigDifference);

DefFloatEntry(FloatDifference, !*FDifference);

DefArith2Entry(Times2, WTimes2, FloatTimes2, BigTimes2);

DefFloatEntry(FloatTimes2, !*FTimes2);

DefArith2Entry(Quotient, WQuotient, FloatQuotient, BigQuotient);

DefFloatEntry(FloatQuotient, !*FQuotient);

DefArithPred2Entry(GreaterP, WGreaterP, FloatGreaterP, BigGreaterP);

procedure FloatGreaterP(X, Y);
    if !*FGreaterP(FloatBase FltInf X, FloatBase FltInf Y) then T else NIL;

DefArithPred2Entry(LessP, WLessP, FloatLessP, BigLessP);

procedure FloatLessP(X, Y);
    if !*FLessP(FloatBase FltInf X, FloatBase FltInf Y) then T else NIL;

DefInt2Entry(Remainder, WRemainder, BigRemainder);

DefInt2Entry(LAnd, WAnd, BigLAnd);

DefInt2Entry(LOr, WOr, BigLOr);

DefInt2Entry(LXOr, WXOr, BigLXOr);

DefInt2Entry(LShift, WShift, BigLShift);

PutD('LSH, 'EXPR, cdr GetD 'LShift);

DefArith1Entry(Add1, IAdd1, lambda X; FloatPlus2(X, '1.0), BigAdd1);

DefArith1Entry(Sub1, ISub1, lambda X; FloatDifference(X, '1.0), BigSub1);

DefArith1Entry(Minus, IMinus, lambda X; FloatDifference('0.0, X), BigMinus);

DefArith1Entry(Fix, lambda X; X, FloatFix, lambda X; X);

procedure FloatFix X;
    Sys2Int !*WFix FloatBase FltInf X;

procedure Float X;
    case Tag X of
	POSINT, NEGINT:
	    IntFloat X;
	FIXN:
	    IntFloat FixVal FixInf X;
	FLTN:
	    X;
	BIGN:
	    FloatBigArg X;
	default:
	    NonNumber1Error(X, 'Float);
    end;

procedure IntFloat X;
begin scalar F;
    F := GtFLTN();
    !*WFloat(FloatBase F, X);
    return MkFLTN F;
end;

DefArithPred1Entry(MinusP, IMinusP, lambda X; FloatLessP(X, '0.0), BigMinusP);

DefArithPred1Entry(ZeroP, IZeroP, lambda X; EQN(X, '0.0), ReturnNil);

DefArithPred1Entry(OneP, IOneP, lambda X; EQN(X, '1.0), ReturnNil);

syslsp procedure ReturnNil U;
    NIL;

syslsp procedure IsInum U;
 IsInumMac U;

off Syslisp;

END;