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