arithmetic.red 14 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505
  1. %
  2. % ARITHMETIC.RED - Arithmetic routines for PSL with new integer tags
  3. %
  4. % Author: Eric Benson
  5. % Symbolic Computation Group
  6. % Computer Science Dept.
  7. % University of Utah
  8. % Date: 17 January 1982
  9. % Copyright (c) 1982 University of Utah
  10. %
  11. CompileTime flag('(TwoArgDispatch TwoArgDispatch1 TwoArgError
  12. OneArgDispatch OneArgDispatch1
  13. OneArgPredicateDispatch OneArgPredicateDispatch1
  14. OneArgError IntAdd1 IntSub1 IntPlus2 IntTimes2
  15. IntDifference
  16. IntQuotient IntRemainder IntLShift IntLAnd IntLOr
  17. IntLXOr IntGreaterP IntLessP IntMinus IntMinusP
  18. IntZeroP IntOneP IntLNot FloatIntArg
  19. FloatAdd1 FloatSub1 FloatPlus2 FloatTimes2
  20. FloatQuotient FloatRemainder FloatDifference
  21. FloatGreaterP FloatLessP FloatMinus FloatMinusP
  22. FloatZeroP FloatOneP StaticIntFloat FloatFix
  23. NonInteger1Error NonInteger2Error
  24. MakeFixnum BigFloatFix),
  25. 'InternalFunction);
  26. on SysLisp;
  27. CompileTime <<
  28. syslsp macro procedure IsInum U;
  29. list('(lambda (X) (eq (SignedField X
  30. (ISub1 (WConst InfStartingBit))
  31. (IAdd1 (WConst InfBitLength)))
  32. X)),
  33. second U);
  34. >>;
  35. internal WConst IntFunctionEntry = 0,
  36. FloatFunctionEntry = 1,
  37. FunctionNameEntry = 2;
  38. syslsp procedure TwoArgDispatch(FirstArg, SecondArg);
  39. TwoArgDispatch1(FirstArg, SecondArg, Tag FirstArg, Tag SecondArg);
  40. lap '((!*entry TwoArgDispatch1 expr 4)
  41. (!*JUMPNOTEQ (Label NotNeg1) (reg 3) (WConst NegInt))
  42. (!*MOVE (WConst PosInt) (reg 3))
  43. NotNeg1
  44. (!*JUMPNOTEQ (Label NotNeg2) (reg 4) (WConst NegInt))
  45. (!*MOVE (WConst PosInt) (reg 4))
  46. NotNeg2
  47. (!*JUMPWGREATERP (Label NonNumeric) (reg 3) (WConst FltN))
  48. (!*JUMPWGREATERP (Label NonNumeric) (reg 4) (WConst FltN))
  49. (!*WSHIFT (reg 3) (WConst 2))
  50. (!*WPLUS2 (reg 4) (reg 3))
  51. (!*POP (reg 3))
  52. (!*JUMPON (reg 4) 0 15 ((Label IntInt)
  53. (Label IntFix)
  54. (Label TemporaryNonEntry)
  55. (Label IntFloat)
  56. (Label FixInt)
  57. (Label FixFix)
  58. (Label TemporaryNonEntry)
  59. (Label FixFloat)
  60. (Label TemporaryNonEntry)
  61. (Label TemporaryNonEntry)
  62. (Label TemporaryNonEntry)
  63. (Label TemporaryNonEntry)
  64. (Label FloatInt)
  65. (Label FloatFix)
  66. (Label TemporaryNonEntry)
  67. (Label FloatFloat)))
  68. TemporaryNonEntry
  69. (!*JCALL TwoArgError)
  70. FixInt
  71. (!*FIELD (reg 1) (reg 1) % grab the value for the fixnum
  72. (WConst InfStartingBit) (WConst InfBitLength))
  73. (!*MOVE (MEMORY (reg 1) (WConst AddressingUnitsPerItem)) (reg 1))
  74. (!*JUMP (MEMORY (MEMORY (reg 3) (WConst 0)) (WConst 0)))
  75. FixFix
  76. (!*FIELD (reg 1) (reg 1) % grab the value for the fixnum
  77. (WConst InfStartingBit) (WConst InfBitLength))
  78. (!*MOVE (MEMORY (reg 1) (WConst AddressingUnitsPerItem)) (reg 1))
  79. IntFix
  80. (!*FIELD (reg 2) (reg 2)
  81. (WConst InfStartingBit) (WConst InfBitLength))
  82. (!*MOVE (MEMORY (reg 2) (WConst AddressingUnitsPerItem)) (reg 2))
  83. IntInt
  84. (!*JUMP (MEMORY (MEMORY (reg 3) (WConst 0)) (WConst 0)))
  85. FixFloat
  86. (!*FIELD (reg 1) (reg 1)
  87. (WConst InfStartingBit) (WConst InfBitLength))
  88. (!*MOVE (MEMORY (reg 1) (WConst AddressingUnitsPerItem)) (reg 1))
  89. IntFloat
  90. (!*PUSH (reg 3))
  91. (!*PUSH (reg 2))
  92. (!*CALL StaticIntFloat)
  93. (!*POP (reg 2))
  94. (!*POP (reg 3))
  95. (!*JUMP (MEMORY (MEMORY (reg 3)
  96. (WConst (times2 (WConst AddressingUnitsPerItem)
  97. (WConst FloatFunctionEntry))))
  98. (WConst 0)))
  99. FloatFix
  100. (!*FIELD (reg 2) (reg 2)
  101. (WConst InfStartingBit) (WConst InfBitLength))
  102. (!*MOVE (MEMORY (reg 2) (WConst AddressingUnitsPerItem)) (reg 2))
  103. FloatInt
  104. (!*PUSH (reg 3))
  105. (!*PUSH (reg 1))
  106. (!*MOVE (reg 2) (reg 1))
  107. (!*CALL StaticIntFloat)
  108. (!*MOVE (reg 1) (reg 2))
  109. (!*POP (reg 1))
  110. (!*POP (reg 3))
  111. (!*JUMP (MEMORY (MEMORY (reg 3)
  112. (WConst (times2 (WConst AddressingUnitsPerItem)
  113. (WConst FloatFunctionEntry))))
  114. (WConst 0)))
  115. FloatFloat
  116. (!*JUMP (MEMORY (MEMORY (reg 3)
  117. (WConst (times2 (WConst AddressingUnitsPerItem)
  118. (WConst FloatFunctionEntry))))
  119. (WConst 0)))
  120. NonNumeric
  121. (!*POP (reg 3))
  122. (!*JCALL TwoArgError)
  123. );
  124. syslsp procedure TwoArgError(FirstArg, SecondArg, DispatchTable);
  125. ContinuableError('99,
  126. '"Non-numeric argument in arithmetic",
  127. list(DispatchTable[FunctionNameEntry],
  128. FirstArg,
  129. SecondArg));
  130. syslsp procedure NonInteger2Error(FirstArg, SecondArg, DispatchTable);
  131. ContinuableError('99,
  132. '"Non-integer argument in arithmetic",
  133. list(DispatchTable[FunctionNameEntry],
  134. FirstArg,
  135. SecondArg));
  136. syslsp procedure NonInteger1Error(Arg, DispatchTable);
  137. ContinuableError('99,
  138. '"Non-integer argument in arithmetic",
  139. list(DispatchTable[FunctionNameEntry],
  140. Arg));
  141. syslsp procedure OneArgDispatch FirstArg;
  142. OneArgDispatch1(FirstArg, Tag FirstArg);
  143. lap '((!*entry OneArgDispatch1 expr 2)
  144. (!*JUMPNOTEQ (Label NotNeg1) (reg 2) (WConst NegInt))
  145. (!*MOVE (WConst PosInt) (reg 2))
  146. NotNeg1
  147. (!*POP (reg 3))
  148. (!*JUMPON (reg 2) 0 3 ((Label OneInt)
  149. (Label OneFix)
  150. (Label TemporaryNonEntry)
  151. (Label OneFloat)))
  152. TemporaryNonEntry
  153. (!*JCALL OneArgError)
  154. OneFix
  155. (!*FIELD (reg 1) (reg 1)
  156. (WConst InfStartingBit) (WConst InfBitLength))
  157. (!*MOVE (MEMORY (reg 1) (WConst AddressingUnitsPerItem)) (reg 1))
  158. OneInt
  159. (!*JUMP (MEMORY (MEMORY (reg 3) (WConst 0)) (WConst 0)))
  160. OneFloat
  161. (!*JUMP (MEMORY (MEMORY (reg 3)
  162. (WConst (times2 (WConst AddressingUnitsPerItem)
  163. (WConst FloatFunctionEntry))))
  164. (WConst 0)))
  165. );
  166. syslsp procedure OneArgError(FirstArg, Dummy, DispatchTable);
  167. ContinuableError('99,
  168. '"Non-numeric argument in arithmetic",
  169. list(DispatchTable[FunctionNameEntry],
  170. FirstArg));
  171. syslsp procedure OneArgPredicateDispatch FirstArg;
  172. OneArgPredicateDispatch1(FirstArg, Tag FirstArg);
  173. lap '((!*entry OneArgPredicateDispatch1 expr 2)
  174. (!*JUMPNOTEQ (Label NotNeg1) (reg 2) (WConst NegInt))
  175. (!*MOVE (WConst PosInt) (reg 2))
  176. NotNeg1
  177. (!*POP (reg 3))
  178. (!*JUMPON (reg 2) 0 3 ((Label OneInt)
  179. (Label OneFix)
  180. (Label TemporaryNonEntry)
  181. (Label OneFloat)))
  182. TemporaryNonEntry
  183. (!*MOVE (QUOTE NIL) (reg 1))
  184. (!*EXIT 0)
  185. OneFix
  186. (!*FIELD (reg 1) (reg 1)
  187. (WConst InfStartingBit) (WConst InfBitLength))
  188. (!*MOVE (MEMORY (reg 1) (WConst AddressingUnitsPerItem)) (reg 1))
  189. OneInt
  190. (!*JUMP (MEMORY (MEMORY (reg 3) (WConst 0)) (WConst 0)))
  191. OneFloat
  192. (!*JUMP (MEMORY (MEMORY (reg 3)
  193. (WConst (times2 (WConst AddressingUnitsPerItem)
  194. (WConst FloatFunctionEntry))))
  195. (WConst 0)))
  196. );
  197. syslsp procedure MakeFixnum N;
  198. begin scalar F;
  199. F := GtFIXN();
  200. FixVal F := N;
  201. return MkFIXN F;
  202. end;
  203. syslsp procedure BigFloatFix N;
  204. StdError '"Bignums not yet supported";
  205. syslsp procedure ReturnNIL();
  206. NIL;
  207. syslsp procedure ReturnFirstArg Arg;
  208. Arg;
  209. internal WArray StaticFloatBuffer = [1, 0, 0];
  210. internal WVar StaticFloatItem = MkItem(FLTN, StaticFloatBuffer);
  211. syslsp procedure StaticIntFloat Arg;
  212. << !*WFloat(&StaticFloatBuffer[1], Arg);
  213. StaticFloatItem >>;
  214. off SysLisp;
  215. CompileTime <<
  216. macro procedure DefArith2Entry U;
  217. DefArithEntry(2 . 'TwoArgDispatch . StupidParserFix cdr U);
  218. macro procedure DefArith1Entry U;
  219. DefArithEntry(1 . 'OneArgDispatch . StupidParserFix cdr U);
  220. macro procedure DefArith1PredicateEntry U;
  221. DefArithEntry(1 . 'OneArgPredicateDispatch . StupidParserFix cdr U);
  222. lisp procedure StupidParserFix X;
  223. % Goddamn Rlisp parser won't let me just give "Difference" as the parameter
  224. % to a macro
  225. if null X then X
  226. else RemQuote car X . StupidParserFix cdr X;
  227. lisp procedure RemQuote X;
  228. if EqCar(X, 'QUOTE) then cadr X else X;
  229. lisp procedure DefArithEntry L;
  230. SublA(Pair('(NumberOfArguments
  231. DispatchRoutine
  232. NameOfFunction
  233. IntFunction
  234. BigFunction
  235. FloatFunction),
  236. L),
  237. quote(lap '((!*entry NameOfFunction expr NumberOfArguments)
  238. (!*Call DispatchRoutine)
  239. (fullword (InternalEntry IntFunction))
  240. % (fullword (InternalEntry BigFunction))
  241. (fullword (InternalEntry FloatFunction))
  242. (fullword (MkItem (WConst ID)
  243. (IDLoc NameOfFunction))))));
  244. >>;
  245. DefArith2Entry(Plus2, IntPlus2, BigPlus2, FloatPlus2);
  246. syslsp procedure IntPlus2(FirstArg, SecondArg);
  247. if IsInum(FirstArg := WPlus2(FirstArg, SecondArg)) then
  248. FirstArg
  249. else
  250. MakeFixnum FirstArg;
  251. syslsp procedure FloatPlus2(FirstArg, SecondArg);
  252. begin scalar F;
  253. F := GtFLTN();
  254. !*FPlus2(FloatBase F, FloatBase FltInf FirstArg,
  255. FloatBase FltInf SecondArg);
  256. return MkFLTN F;
  257. end;
  258. DefArith2Entry('Difference, IntDifference, BigDifference, FloatDifference);
  259. syslsp procedure IntDifference(FirstArg, SecondArg);
  260. if IsInum(FirstArg := WDifference(FirstArg, SecondArg)) then
  261. FirstArg
  262. else
  263. MakeFixnum FirstArg;
  264. syslsp procedure FloatDifference(FirstArg, SecondArg);
  265. begin scalar F;
  266. F := GtFLTN();
  267. !*FDifference(FloatBase F, FloatBase FltInf FirstArg,
  268. FloatBase FltInf SecondArg);
  269. return MkFLTN F;
  270. end;
  271. DefArith2Entry(Times2, IntTimes2, BigTimes2, FloatTimes2);
  272. % What about overflow?
  273. syslsp procedure IntTimes2(FirstArg, SecondArg);
  274. begin scalar Result;
  275. Result := WTimes2(FirstArg, SecondArg);
  276. return if not IsInum Result then MakeFixnum Result else Result;
  277. end;
  278. syslsp procedure FloatTimes2(FirstArg, SecondArg);
  279. begin scalar F;
  280. F := GtFLTN();
  281. !*FTimes2(FloatBase F, FloatBase FltInf FirstArg,
  282. FloatBase FltInf SecondArg);
  283. return MkFLTN F;
  284. end;
  285. DefArith2Entry('Quotient, IntQuotient, BigQuotient, FloatQuotient);
  286. syslsp procedure IntQuotient(FirstArg, SecondArg);
  287. begin scalar Result;
  288. if SecondArg eq 0 then return
  289. ContError(99,
  290. "Attempt to divide by zero in Quotient",
  291. Quotient(FirstArg, SecondArg));
  292. Result := WQuotient(FirstArg, SecondArg);
  293. return if not IsInum Result then MakeFixnum Result else Result;
  294. end;
  295. syslsp procedure FloatQuotient(FirstArg, SecondArg);
  296. begin scalar F;
  297. if FloatZeroP SecondArg then return
  298. ContError(99,
  299. "Attempt to divide by zero in Quotient",
  300. Quotient(FirstArg, SecondArg));
  301. F := GtFLTN();
  302. !*FQuotient(FloatBase F, FloatBase FltInf FirstArg,
  303. FloatBase FltInf SecondArg);
  304. return MkFLTN F;
  305. end;
  306. DefArith2Entry(Remainder, IntRemainder, BigRemainder, FloatRemainder);
  307. syslsp procedure IntRemainder(FirstArg, SecondArg);
  308. begin scalar Result;
  309. if SecondArg eq 0 then return
  310. ContError(99,
  311. "Attempt to divide by zero in Remainder",
  312. Remainder(FirstArg, SecondArg));
  313. Result := WRemainder(FirstArg, SecondArg);
  314. return if not IsInum Result then MakeFixnum Result else Result;
  315. end;
  316. syslsp procedure FloatRemainder(FirstArg, SecondArg);
  317. begin scalar F; % This is pretty silly
  318. F := GtFLTN(); % might be better to signal an error
  319. !*FQuotient(FloatBase F, FloatBase FltInf FirstArg,
  320. FloatBase FltInf SecondArg);
  321. !*FTimes2(FloatBase F, FloatBase F, FloatBase FltInf SecondArg);
  322. !*FDifference(FloatBase F, FloatBase FltInf FirstArg, FloatBase F);
  323. return MkFLTN F;
  324. end;
  325. DefArith2Entry(LAnd, IntLAnd, BigLAnd, NonInteger2Error);
  326. syslsp procedure IntLAnd(FirstArg, SecondArg);
  327. if IsInum(FirstArg := WAnd(FirstArg, SecondArg)) then
  328. FirstArg
  329. else MakeFixnum FirstArg;
  330. DefArith2Entry(LOr, IntLOr, BigLOr, NonInteger2Error);
  331. syslsp procedure IntLOr(FirstArg, SecondArg);
  332. if IsInum(FirstArg := WOr(FirstArg, SecondArg)) then
  333. FirstArg
  334. else MakeFixnum FirstArg;
  335. DefArith2Entry(LXOr, IntLXOr, BigLXOr, NonInteger2Error);
  336. syslsp procedure IntLXOr(FirstArg, SecondArg);
  337. if IsInum(FirstArg := WXOr(FirstArg, SecondArg)) then
  338. FirstArg
  339. else MakeFixnum FirstArg;
  340. DefArith2Entry(LShift, IntLShift, BigLShift, NonInteger2Error);
  341. PutD('LSH, 'EXPR, cdr GetD 'LShift);
  342. syslsp procedure IntLShift(FirstArg, SecondArg);
  343. begin scalar Result;
  344. Result := WShift(FirstArg, SecondArg);
  345. return if not IsInum Result then MakeFixnum Result else Result;
  346. end;
  347. DefArith2Entry('GreaterP, IntGreaterP, BigGreaterP, FloatGreaterP);
  348. syslsp procedure IntGreaterP(FirstArg, SecondArg);
  349. WGreaterP(FirstArg, SecondArg);
  350. syslsp procedure FloatGreaterP(FirstArg, SecondArg);
  351. !*FGreaterP(FloatBase FltInf FirstArg,
  352. FloatBase FltInf SecondArg) and T;
  353. DefArith2Entry('LessP, IntLessP, BigLessP, FloatLessP);
  354. syslsp procedure IntLessP(FirstArg, SecondArg);
  355. WLessP(FirstArg, SecondArg);
  356. syslsp procedure FloatLessP(FirstArg, SecondArg);
  357. !*FLessP(FloatBase FltInf FirstArg,
  358. FloatBase FltInf SecondArg) and T;
  359. DefArith1Entry(Add1, IntAdd1, BigAdd1, FloatAdd1);
  360. syslsp procedure IntAdd1 FirstArg;
  361. if IsInum(FirstArg := WPlus2(FirstArg, 1)) then
  362. FirstArg
  363. else
  364. MakeFixnum FirstArg;
  365. lisp procedure FloatAdd1 FirstArg;
  366. FloatPlus2(FirstArg, 1.0);
  367. DefArith1Entry(Sub1, IntSub1, BigSub1, FloatSub1);
  368. lisp procedure IntSub1 FirstArg;
  369. if IsInum(FirstArg := WDifference(FirstArg, 1)) then
  370. FirstArg
  371. else
  372. MakeFixnum FirstArg;
  373. lisp procedure FloatSub1 FirstArg;
  374. FloatDifference(FirstArg, 1.0);
  375. DefArith1Entry(LNot, IntLNot, BigLNot, NonInteger1Error);
  376. lisp procedure IntLNot X;
  377. if IsInum(X := WNot X) then X else MakeFixnum X;
  378. DefArith1Entry('Minus, IntMinus, BigMinus, FloatMinus);
  379. lisp procedure IntMinus FirstArg;
  380. if IsInum(FirstArg := WMinus FirstArg) then
  381. FirstArg
  382. else
  383. MakeFixnum FirstArg;
  384. lisp procedure FloatMinus FirstArg;
  385. FloatDifference(0.0, FirstArg);
  386. DefArith1Entry(Fix, ReturnFirstArg, ReturnFirstArg, FloatFix);
  387. syslsp procedure FloatFix Arg;
  388. begin scalar R;
  389. return if IsInum(R :=!*WFix FloatBase FltInf Arg) then R
  390. else MakeFixnum R;
  391. end;
  392. DefArith1Entry(Float, FloatIntArg, FloatBigArg, ReturnFirstArg);
  393. syslsp procedure FloatIntArg Arg;
  394. begin scalar F;
  395. F := GtFLTN();
  396. !*WFloat(FloatBase F, Arg);
  397. return MkFLTN F;
  398. end;
  399. DefArith1PredicateEntry(MinusP, IntMinusP, BigMinusP, FloatMinusP);
  400. syslsp procedure IntMinusP FirstArg;
  401. WLessP(FirstArg, 0);
  402. lisp procedure FloatMinusP FirstArg;
  403. FloatLessP(FirstArg, 0.0);
  404. DefArith1PredicateEntry(ZeroP, IntZeroP, ReturnNIL, FloatZeroP);
  405. lisp procedure IntZeroP FirstArg;
  406. FirstArg = 0;
  407. lisp procedure FloatZeroP FirstArg;
  408. EQN(FirstArg, 0.0);
  409. DefArith1PredicateEntry(OneP, IntOneP, ReturnNIL, FloatOneP);
  410. lisp procedure IntOneP FirstArg;
  411. FirstArg = 1;
  412. lisp procedure FloatOneP FirstArg;
  413. EQN(FirstArg, 1.0);
  414. END;