Artifact 429cbd53139a609d15d0a9ea534eb30f51525637def2c2e5a3e9868ada19a1a9:
- File
psl-1983/3-1/util/bigface.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: 5239) [annotate] [blame] [check-ins using] [more...]
- File
psl-1983/util/bigface.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: 5239) [annotate] [blame] [check-ins using]
%. BIGFACE.RED - Bignum Interfacing % M.L. Griss and B Morrison % 25 June 1982 % -------------------------------------------------------------------------- % Revision History: % 21 December, 82: MLG % Change PRIN1 and PRIN2 hooks to refer to RecursiveChannelprinx % which changed in PK:PRINTERS.RED for prinlevel stuff % November: Variety of Bug Fixes by A. Norman off usermode; % Use the BIGN tag for better Interface imports '(vector!-fix arith bigbig); compiletime<<load syslisp; load fast!-vector; load inum; load if!-system>>; on comp; fluid '(WordHi!* WordLow!* BBase!* FloatHi!* FloatLow!*); smacro procedure PutBig(b,i,val); IputV(b,i,val); smacro procedure GetBig(b,i); IgetV(B,i); % on syslisp; % % procedure BigP x; % Tag(x) eq BIGN; % % off syslisp; lisp procedure BignumP (V); BigP V and ((GetBig(V,0) eq 'BIGPOS) or (GetBig(V,0) eq 'BIGNEG)); lisp procedure NonBigNumError(V,L); StdError BldMsg(" Expect a BIGNUM in %r, given %p%n",L,V); lisp procedure BSize V; (BignumP V and VecLen VecInf V) or 0; lisp procedure GtPOS N; Begin Scalar B; B:=MkVect N; IPutV(B,0,'BIGPOS); Return MkBigN Vecinf B; End; lisp procedure GtNeg N; Begin Scalar B; B:=MkVect N; IPutV(B,0,'BIGNEG); Return MkBigN VecInf B; End; lisp procedure TrimBigNum V3; % truncate trailing 0 If Not BignumP V3 then NonBigNumError(V3,'TrimBigNum) else TrimBigNum1(V3,BSize V3); lisp procedure TrimBigNum1(B,L3); Begin scalar v3; V3:=BigAsVec B; While IGreaterP(L3,0) and IZeroP IGetV(V3,L3) do L3:=ISub1 L3; If IZerop UpBv TruncateVector(V3,L3) then return GtPOS 0 else return B; end; lisp procedure BigAsVec B; MkVec Inf B; lisp procedure VecAsBig V; MkBig Inf V; % -- Output--- if_system(VAX, <<setbits 32; FloatHi!*:=btimes2(bdifference(btwopower 67, btwopower 11), btwopower 60);% Largest representable float. FloatLow!*:=BMinus FloatHi!*>>); if_system(PDP10, <<setbits 36; FloatHi!*:=btimes2(bsub1 btwopower 62, btwopower 65); FloatLow!*:=BMinus FloatHi!*>>); % MLG Change to interface to Recursive hooks, added for % Prinlevel stuff CopyD('OldChannelPrin1,'RecursiveChannelPrin1); CopyD('OldChannelPrin2,'RecursiveChannelPrin2); Lisp Procedure RecursiveChannelPrin1(Channel,U,Level); <<if BigNumP U then BChannelPrin2(Channel,U) else OldChannelPrin1(Channel, U,Level);U>>; Lisp Procedure RecursiveChannelPrin2(Channel,U,level); <<If BigNumP U then BChannelPrin2(Channel, U) else OldChannelPrin2(Channel, U,level);U>>; lisp procedure big2sys U; begin scalar L,Sn,res,I; L:=BSize U; if IZeroP L then return 0; Sn:=BMinusP U; res:=IGetV(U,L); I:=ISub1 L; while I neq 0 do <<res:=ITimes2(res, bbase!*); res:=IPlus2(res, IGetV(U,I)); I:=ISub1 I>>; if Sn then Res:=IMinus Res; return Res; end; smacro procedure checkifreallybig U; (lambda UU; % This construction needed to avoid repeated evaluation; if BLessP(UU, WordLow!*) or BGreaterp(UU,WordHi!*) then UU else sys2int big2sys UU)(U); smacro procedure checkifreallybigpair U; (lambda VV; checkifreallybig car VV . checkifreallybig cdr VV)(U); smacro procedure checkifreallybigornil U; (lambda UU; if Null UU or BLessp(UU, WordLow!*) or BGreaterP(UU,WordHi!*) then UU else sys2int big2sys UU)(U); lisp procedure BigPlus2(U,V); CheckIfReallyBig BPlus2(U,V); lisp procedure BigDifference(U,V); CheckIfReallyBig BDifference(U,V); lisp procedure BigTimes2(U,V); CheckIfReallyBig BTimes2(U,V); lisp procedure BigDivide(U,V); CheckIfReallyBigPair BDivide(U,V); lisp procedure BigQuotient(U,V); CheckIfReallyBig BQuotient(U,V); lisp procedure BigRemainder(U,V); CheckIfReallyBig BRemainder(U,V); lisp procedure BigLAnd(U,V); CheckIfReallyBig BLand(U,V); lisp procedure BigLOr(U,V); CheckIfReallyBig BLOr(U,V); lisp procedure BigLXOr(U,V); CheckIfReallyBig BLXor(U,V); lisp procedure BigLShift(U,V); CheckIfReallyBig BLShift(U,V); lisp procedure BigGreaterP(U,V); CheckIfReallyBigOrNil BGreaterP(U,V); lisp procedure BigLessP(U,V); CheckIfReallyBigOrNil BLessP(U,V); lisp procedure BigAdd1 U; CheckIfReallyBig BAdd1 U; lisp procedure BigSub1 U; CheckIfReallyBig BSub1 U; lisp procedure BigLNot U; CheckIfReallyBig BLNot U; lisp procedure BigMinus U; CheckIfReallyBig BMinus U; lisp procedure FloatBigArg U; FloatFromBigNum U; lisp procedure BigMinusP U; CheckIfReallyBigOrNil BMinusP U; % ---- Input ---- lisp procedure MakeStringIntoLispInteger(Str,Radix,Sn); CheckIfReallyBig BRead(Str,Radix,Sn); % Coercion/Transfer Functions copyd('oldFloatFix,'FloatFix); procedure floatfix U; if U < BBase!* then OldFloatFix U else bigfromfloat U; copyd('oldMakeFixNum, 'MakeFixNum); procedure MakeFixNum N; % temporary; check range? Begin; n:=oldMakeFixNum N; return int2b N; end; syslsp procedure StaticIntBig Arg; % Convert an INT to a BIG int2b Arg; syslsp procedure StaticBigFloat Arg; % Convert a BigNum to a FLOAT; FloatFromBignum Arg; copyd('oldInt2Sys, 'Int2Sys); procedure Int2Sys N; if BigP N then Big2Sys N else OldInt2Sys n; on syslisp; syslsp procedure IsInum U; U < lispvar bbase!* and U > minus lispvar bbase!*; off syslisp; on usermode;