Artifact 23d2898843c8195de1fd4051d5b5eab9286419396ba657c0019dc72f3a507724:

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

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

%
% ARITHMETIC.RED - Arithmetic routines for PSL with new integer tags
% 
% Author:      Eric Benson
%	       Symbolic Computation Group
%              Computer Science Dept.
%              University of Utah
% Date:        17 January 1982
% Copyright (c) 1982 University of Utah
%

CompileTime flag('(TwoArgDispatch TwoArgDispatch1 TwoArgError
		   OneArgDispatch OneArgDispatch1
		   OneArgPredicateDispatch OneArgPredicateDispatch1
		   OneArgError IntAdd1 IntSub1 IntPlus2 IntTimes2
		   IntDifference
		   IntQuotient IntRemainder IntLShift IntLAnd IntLOr
		   IntLXOr IntGreaterP IntLessP IntMinus IntMinusP
		   IntZeroP IntOneP IntLNot FloatIntArg
		   FloatAdd1 FloatSub1 FloatPlus2 FloatTimes2
		   FloatQuotient FloatRemainder FloatDifference
		   FloatGreaterP FloatLessP FloatMinus FloatMinusP
		   FloatZeroP FloatOneP StaticIntFloat FloatFix
		   NonInteger1Error NonInteger2Error
		   MakeFixnum BigFloatFix),
		 'InternalFunction);

on SysLisp;

CompileTime <<
syslsp macro procedure IsInum U;
    list('(lambda (X) (eq (SignedField X
				       (ISub1 (WConst InfStartingBit))
				       (IAdd1 (WConst InfBitLength)))
			  X)),
	 second U);

>>;

internal WConst IntFunctionEntry = 0,
		FloatFunctionEntry = 1,
		FunctionNameEntry = 2;

syslsp procedure TwoArgDispatch(FirstArg, SecondArg);
    TwoArgDispatch1(FirstArg, SecondArg, Tag FirstArg, Tag SecondArg);

lap '((!*entry TwoArgDispatch1 expr 4)
	(!*JUMPNOTEQ (Label NotNeg1) (reg 3) (WConst NegInt))
	(!*MOVE (WConst PosInt) (reg 3))
NotNeg1
	(!*JUMPNOTEQ (Label NotNeg2) (reg 4) (WConst NegInt))
	(!*MOVE (WConst PosInt) (reg 4))
NotNeg2
	(!*JUMPWGREATERP (Label NonNumeric) (reg 3) (WConst FltN))
	(!*JUMPWGREATERP (Label NonNumeric) (reg 4) (WConst FltN))
	(!*WSHIFT (reg 3) (WConst 2))
	(!*WPLUS2 (reg 4) (reg 3))
	(!*POP (reg 3))
	(!*JUMPON (reg 4) 0 15 ((Label IntInt)
				(Label IntFix)
				(Label TemporaryNonEntry)
				(Label IntFloat)
				(Label FixInt)
				(Label FixFix)
				(Label TemporaryNonEntry)
				(Label FixFloat)
				(Label TemporaryNonEntry)
				(Label TemporaryNonEntry)
				(Label TemporaryNonEntry)
				(Label TemporaryNonEntry)
				(Label FloatInt)
				(Label FloatFix)
				(Label TemporaryNonEntry)
				(Label FloatFloat)))
TemporaryNonEntry
	(!*JCALL TwoArgError)
FixInt
	(!*FIELD (reg 1) (reg 1)	% grab the value for the fixnum
		 (WConst InfStartingBit) (WConst InfBitLength))
	(!*MOVE (MEMORY (reg 1) (WConst AddressingUnitsPerItem)) (reg 1))
	(!*JUMP (MEMORY (MEMORY (reg 3) (WConst 0)) (WConst 0)))
FixFix
	(!*FIELD (reg 1) (reg 1)	% grab the value for the fixnum
		 (WConst InfStartingBit) (WConst InfBitLength))
	(!*MOVE (MEMORY (reg 1) (WConst AddressingUnitsPerItem)) (reg 1))
IntFix
	(!*FIELD (reg 2) (reg 2)
		 (WConst InfStartingBit) (WConst InfBitLength))
	(!*MOVE (MEMORY (reg 2) (WConst AddressingUnitsPerItem)) (reg 2))
IntInt
	(!*JUMP (MEMORY (MEMORY (reg 3) (WConst 0)) (WConst 0)))
FixFloat
	(!*FIELD (reg 1) (reg 1)
		 (WConst InfStartingBit) (WConst InfBitLength))
	(!*MOVE (MEMORY (reg 1) (WConst AddressingUnitsPerItem)) (reg 1))
IntFloat
	(!*PUSH (reg 3))
	(!*PUSH (reg 2))
	(!*CALL StaticIntFloat)
	(!*POP (reg 2))
	(!*POP (reg 3))
	(!*JUMP (MEMORY (MEMORY (reg 3)
				(WConst (times2 (WConst AddressingUnitsPerItem)
						(WConst FloatFunctionEntry))))
			(WConst 0)))
FloatFix
	(!*FIELD (reg 2) (reg 2)
		 (WConst InfStartingBit) (WConst InfBitLength))
	(!*MOVE (MEMORY (reg 2) (WConst AddressingUnitsPerItem)) (reg 2))
FloatInt
	(!*PUSH (reg 3))
	(!*PUSH (reg 1))
	(!*MOVE (reg 2) (reg 1))
	(!*CALL StaticIntFloat)
	(!*MOVE (reg 1) (reg 2))
	(!*POP (reg 1))
	(!*POP (reg 3))
	(!*JUMP (MEMORY (MEMORY (reg 3)
				(WConst (times2 (WConst AddressingUnitsPerItem)
						(WConst FloatFunctionEntry))))
			(WConst 0)))
FloatFloat
	(!*JUMP (MEMORY (MEMORY (reg 3)
				(WConst (times2 (WConst AddressingUnitsPerItem)
						(WConst FloatFunctionEntry))))
			(WConst 0)))
NonNumeric
	(!*POP (reg 3))
	(!*JCALL TwoArgError)
);

syslsp procedure TwoArgError(FirstArg, SecondArg, DispatchTable);
    ContinuableError('99,
		     '"Non-numeric argument in arithmetic",
		     list(DispatchTable[FunctionNameEntry],
			  FirstArg,
			  SecondArg));

syslsp procedure NonInteger2Error(FirstArg, SecondArg, DispatchTable);
    ContinuableError('99,
		     '"Non-integer argument in arithmetic",
		     list(DispatchTable[FunctionNameEntry],
			  FirstArg,
			  SecondArg));

syslsp procedure NonInteger1Error(Arg, DispatchTable);
    ContinuableError('99,
		     '"Non-integer argument in arithmetic",
		     list(DispatchTable[FunctionNameEntry],
			  Arg));

syslsp procedure OneArgDispatch FirstArg;
    OneArgDispatch1(FirstArg, Tag FirstArg);

lap '((!*entry OneArgDispatch1 expr 2)
	(!*JUMPNOTEQ (Label NotNeg1) (reg 2) (WConst NegInt))
	(!*MOVE (WConst PosInt) (reg 2))
NotNeg1
	(!*POP (reg 3))
	(!*JUMPON (reg 2) 0 3 ((Label OneInt)
			       (Label OneFix)
			       (Label TemporaryNonEntry)
			       (Label OneFloat)))
TemporaryNonEntry
	(!*JCALL OneArgError)
OneFix
	(!*FIELD (reg 1) (reg 1)
		 (WConst InfStartingBit) (WConst InfBitLength))
	(!*MOVE (MEMORY (reg 1) (WConst AddressingUnitsPerItem)) (reg 1))
OneInt
	(!*JUMP (MEMORY (MEMORY (reg 3) (WConst 0)) (WConst 0)))
OneFloat
	(!*JUMP (MEMORY (MEMORY (reg 3)
				(WConst (times2 (WConst AddressingUnitsPerItem)
						(WConst FloatFunctionEntry))))
			(WConst 0)))
);

syslsp procedure OneArgError(FirstArg, Dummy, DispatchTable);
    ContinuableError('99,
		     '"Non-numeric argument in arithmetic",
		     list(DispatchTable[FunctionNameEntry],
			  FirstArg));

syslsp procedure OneArgPredicateDispatch FirstArg;
    OneArgPredicateDispatch1(FirstArg, Tag FirstArg);

lap '((!*entry OneArgPredicateDispatch1 expr 2)
	(!*JUMPNOTEQ (Label NotNeg1) (reg 2) (WConst NegInt))
	(!*MOVE (WConst PosInt) (reg 2))
NotNeg1
	(!*POP (reg 3))
	(!*JUMPON (reg 2) 0 3 ((Label OneInt)
			       (Label OneFix)
			       (Label TemporaryNonEntry)
			       (Label OneFloat)))
TemporaryNonEntry
	(!*MOVE (QUOTE NIL) (reg 1))
	(!*EXIT 0)
OneFix
	(!*FIELD (reg 1) (reg 1)
		 (WConst InfStartingBit) (WConst InfBitLength))
	(!*MOVE (MEMORY (reg 1) (WConst AddressingUnitsPerItem)) (reg 1))
OneInt
	(!*JUMP (MEMORY (MEMORY (reg 3) (WConst 0)) (WConst 0)))
OneFloat
	(!*JUMP (MEMORY (MEMORY (reg 3)
				(WConst (times2 (WConst AddressingUnitsPerItem)
						(WConst FloatFunctionEntry))))
			(WConst 0)))
);

syslsp procedure MakeFixnum N;
begin scalar F;
    F := GtFIXN();
    FixVal F := N;
    return MkFIXN F;
end;

syslsp procedure BigFloatFix N;
    StdError '"Bignums not yet supported";

syslsp procedure ReturnNIL();
    NIL;

syslsp procedure ReturnFirstArg Arg;
    Arg;

internal WArray StaticFloatBuffer = [1, 0, 0];

internal WVar StaticFloatItem = MkItem(FLTN, StaticFloatBuffer);

syslsp procedure StaticIntFloat Arg;
<<  !*WFloat(&StaticFloatBuffer[1], Arg);
    StaticFloatItem >>;

off SysLisp;

CompileTime <<
macro procedure DefArith2Entry U;
    DefArithEntry(2 . 'TwoArgDispatch . StupidParserFix cdr U);

macro procedure DefArith1Entry U;
    DefArithEntry(1 . 'OneArgDispatch . StupidParserFix cdr U);

macro procedure DefArith1PredicateEntry U;
    DefArithEntry(1 . 'OneArgPredicateDispatch . StupidParserFix cdr U);

lisp procedure StupidParserFix X;
% Goddamn Rlisp parser won't let me just give "Difference" as the parameter
% to a macro
    if null X then X
    else RemQuote car X . StupidParserFix cdr X;

lisp procedure RemQuote X;
    if EqCar(X, 'QUOTE) then cadr X else X;

lisp procedure DefArithEntry L;
    SublA(Pair('(NumberOfArguments
		 DispatchRoutine
		 NameOfFunction
		 IntFunction
		 BigFunction
		 FloatFunction),
		L),
	  quote(lap '((!*entry NameOfFunction expr NumberOfArguments)
		      (!*Call DispatchRoutine)
		      (fullword (InternalEntry IntFunction))
%		      (fullword (InternalEntry BigFunction))
		      (fullword (InternalEntry FloatFunction))
		      (fullword (MkItem (WConst ID)
					(IDLoc NameOfFunction))))));
>>;

DefArith2Entry(Plus2, IntPlus2, BigPlus2, FloatPlus2);

syslsp procedure IntPlus2(FirstArg, SecondArg);
    if IsInum(FirstArg := WPlus2(FirstArg, SecondArg)) then
	FirstArg
    else
	MakeFixnum FirstArg;

syslsp procedure FloatPlus2(FirstArg, SecondArg);
begin scalar F;
    F := GtFLTN();
    !*FPlus2(FloatBase F, FloatBase FltInf FirstArg,
			  FloatBase FltInf SecondArg);

    return MkFLTN F;
end;

DefArith2Entry('Difference, IntDifference, BigDifference, FloatDifference);

syslsp procedure IntDifference(FirstArg, SecondArg);
    if IsInum(FirstArg := WDifference(FirstArg, SecondArg)) then
	FirstArg
    else
	MakeFixnum FirstArg;

syslsp procedure FloatDifference(FirstArg, SecondArg);
begin scalar F;
    F := GtFLTN();
    !*FDifference(FloatBase F, FloatBase FltInf FirstArg,
			       FloatBase FltInf SecondArg);

    return MkFLTN F;
end;

DefArith2Entry(Times2, IntTimes2, BigTimes2, FloatTimes2);

% What about overflow?

syslsp procedure IntTimes2(FirstArg, SecondArg);
begin scalar Result;
    Result := WTimes2(FirstArg, SecondArg);
    return if not IsInum Result then MakeFixnum Result else Result;
end;

syslsp procedure FloatTimes2(FirstArg, SecondArg);
begin scalar F;
    F := GtFLTN();
    !*FTimes2(FloatBase F, FloatBase FltInf FirstArg,
			       FloatBase FltInf SecondArg);

    return MkFLTN F;
end;

DefArith2Entry('Quotient, IntQuotient, BigQuotient, FloatQuotient);

syslsp procedure IntQuotient(FirstArg, SecondArg);
begin scalar Result;
    if SecondArg eq 0 then return
	ContError(99,
		  "Attempt to divide by zero in Quotient",
		  Quotient(FirstArg, SecondArg));
    Result := WQuotient(FirstArg, SecondArg);
    return if not IsInum Result then MakeFixnum Result else Result;
end;

syslsp procedure FloatQuotient(FirstArg, SecondArg);
begin scalar F;
    if FloatZeroP SecondArg then return
	ContError(99,
		  "Attempt to divide by zero in Quotient",
		  Quotient(FirstArg, SecondArg));
    F := GtFLTN();
    !*FQuotient(FloatBase F, FloatBase FltInf FirstArg,
			       FloatBase FltInf SecondArg);

    return MkFLTN F;
end;

DefArith2Entry(Remainder, IntRemainder, BigRemainder, FloatRemainder);

syslsp procedure IntRemainder(FirstArg, SecondArg);
begin scalar Result;
    if SecondArg eq 0 then return
	ContError(99,
		  "Attempt to divide by zero in Remainder",
		  Remainder(FirstArg, SecondArg));
    Result := WRemainder(FirstArg, SecondArg);
    return if not IsInum Result then MakeFixnum Result else Result;
end;

syslsp procedure FloatRemainder(FirstArg, SecondArg);
begin scalar F;				% This is pretty silly
    F := GtFLTN();			% might be better to signal an error
    !*FQuotient(FloatBase F,  FloatBase FltInf FirstArg,
			       FloatBase FltInf SecondArg);
    !*FTimes2(FloatBase F, FloatBase F, FloatBase FltInf SecondArg);
    !*FDifference(FloatBase F, FloatBase FltInf FirstArg, FloatBase F);
    return MkFLTN F;
end;

DefArith2Entry(LAnd, IntLAnd, BigLAnd, NonInteger2Error);

syslsp procedure IntLAnd(FirstArg, SecondArg);
    if IsInum(FirstArg := WAnd(FirstArg, SecondArg)) then
	FirstArg
    else MakeFixnum FirstArg;

DefArith2Entry(LOr, IntLOr, BigLOr, NonInteger2Error);

syslsp procedure IntLOr(FirstArg, SecondArg);
    if IsInum(FirstArg := WOr(FirstArg, SecondArg)) then
	FirstArg
    else MakeFixnum FirstArg;

DefArith2Entry(LXOr, IntLXOr, BigLXOr, NonInteger2Error);

syslsp procedure IntLXOr(FirstArg, SecondArg);
    if IsInum(FirstArg := WXOr(FirstArg, SecondArg)) then
	FirstArg
    else MakeFixnum FirstArg;

DefArith2Entry(LShift, IntLShift, BigLShift, NonInteger2Error);

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

syslsp procedure IntLShift(FirstArg, SecondArg);
begin scalar Result;
    Result := WShift(FirstArg, SecondArg);
    return if not IsInum Result then MakeFixnum Result else Result;
end;

DefArith2Entry('GreaterP, IntGreaterP, BigGreaterP, FloatGreaterP);

syslsp procedure IntGreaterP(FirstArg, SecondArg);
    WGreaterP(FirstArg, SecondArg);

syslsp procedure FloatGreaterP(FirstArg, SecondArg);
    !*FGreaterP(FloatBase FltInf FirstArg,
		FloatBase FltInf SecondArg) and T;

DefArith2Entry('LessP, IntLessP, BigLessP, FloatLessP);

syslsp procedure IntLessP(FirstArg, SecondArg);
    WLessP(FirstArg, SecondArg);

syslsp procedure FloatLessP(FirstArg, SecondArg);
    !*FLessP(FloatBase FltInf FirstArg,
	     FloatBase FltInf SecondArg) and T;

DefArith1Entry(Add1, IntAdd1, BigAdd1, FloatAdd1);

syslsp procedure IntAdd1 FirstArg;
    if IsInum(FirstArg := WPlus2(FirstArg, 1)) then
	FirstArg
    else
	MakeFixnum FirstArg;

lisp procedure FloatAdd1 FirstArg;
    FloatPlus2(FirstArg, 1.0);

DefArith1Entry(Sub1, IntSub1, BigSub1, FloatSub1);

lisp procedure IntSub1 FirstArg;
    if IsInum(FirstArg := WDifference(FirstArg, 1)) then
	FirstArg
    else
	MakeFixnum FirstArg;

lisp procedure FloatSub1 FirstArg;
    FloatDifference(FirstArg, 1.0);

DefArith1Entry(LNot, IntLNot, BigLNot, NonInteger1Error);

lisp procedure IntLNot X;
    if IsInum(X := WNot X) then X else MakeFixnum X;

DefArith1Entry('Minus, IntMinus, BigMinus, FloatMinus);

lisp procedure IntMinus FirstArg;
    if IsInum(FirstArg := WMinus FirstArg) then
	FirstArg
    else
	MakeFixnum FirstArg;

lisp procedure FloatMinus FirstArg;
    FloatDifference(0.0, FirstArg);

DefArith1Entry(Fix, ReturnFirstArg, ReturnFirstArg, FloatFix);

syslsp procedure FloatFix Arg;
begin scalar R;
    return if IsInum(R :=!*WFix FloatBase FltInf Arg) then R
	   else MakeFixnum R;
end;

DefArith1Entry(Float, FloatIntArg, FloatBigArg, ReturnFirstArg);

syslsp procedure FloatIntArg Arg;
begin scalar F;
    F := GtFLTN();
    !*WFloat(FloatBase F, Arg);
    return MkFLTN F;
end;


DefArith1PredicateEntry(MinusP, IntMinusP, BigMinusP, FloatMinusP);

syslsp procedure IntMinusP FirstArg;
    WLessP(FirstArg, 0);

lisp procedure FloatMinusP FirstArg;
    FloatLessP(FirstArg, 0.0);

DefArith1PredicateEntry(ZeroP, IntZeroP, ReturnNIL, FloatZeroP);

lisp procedure IntZeroP FirstArg;
    FirstArg = 0;

lisp procedure FloatZeroP FirstArg;
    EQN(FirstArg, 0.0);

DefArith1PredicateEntry(OneP, IntOneP, ReturnNIL, FloatOneP);

lisp procedure IntOneP FirstArg;
    FirstArg = 1;

lisp procedure FloatOneP FirstArg;
    EQN(FirstArg, 1.0);

END;