Artifact 30832500cb65befa8b5b732ab463e680198cb404663acb43d6e1d946bf618e1b:

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

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

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

% Author:      Eric Benson and Martin Griss
%              Symbolic Computation Group
%              Computer Science Dept.
%              University of Utah
% Date:        9 August 1982
% Copyright (c) 1982 University of Utah
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% The MODEL:
% It is assumed that there is a range of INUMs (subset) called
% BETAnums that can be safely operated on by the Wxxx or Ixxx routines
% without loss of precesion or overflow, and return an INUM (or at least
% a SYSINT.
%
% A UNARY operation (UN x) is done as:
%  Procedure UN x;
%    If BetaP x then <<x:=WUN x; if IntRangeP x then x else Sys2Int x>>
%      else UN!-HARD(x);

% A UNARY predicate  (UNP x) is done as:
%  Procedure UNP x;
%    If BetaP x then WUNP x
%      else UNP!-HARD(x);


% A BINARY operation (BIN x y) is done as:
%  Procedure BIN(x,y);
%    If BetaP x and BetaP y 
%	then <<x:=WBIN(x,y); 
%	       if IntRangeP x then x else Sys2Int x>>
%     else BIN!-HARD(x,y);

% A BINARY predicate (BINP x y) is done as:
%  Procedure BINP(x,y);
%    If BetaP x and BetaP y then WBINP(x,y) 
%     else BINP!-HARD(x,y);

% IN some "safe" cases, BetaP can become IntP (beware of *)
% In others, BetaP(y) may be too weak (eg, Lshift and Expt)

% Note: Loading NBIG0 is supposed to define (or redefine)
%       the functions:
%		BetaP
%               Beta2P
%               BetaRangeP
%		Sys2Big
%		FloatFromBignum
%		Sys2Int
%		FloatFix
% Removed IsInum and INTP in favor of BetaP
%
% Mods by MLG, 21 dec 1982
% 	Take off INTERNALFUNCTION form FLOATxxx
%       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;
>>;

expr procedure BetaP x;
% Test tagged number is in Beta Range when BIGNUM loaded
% Will redefine if NBIG loaded
   IntP x;

expr procedure BetaRangeP w;
% Test Word is in Beta Range when BIGNUM loaded
% Ie, is FIXNUM size with no NBIG
% Will redefine if NBIG loaded
   'T;

expr procedure Beta2P(x,y);
% Test if BOTH in Beta range
% Will be redefined if NBIG loaded
  if IntP x then Intp y else NIL;

expr procedure Sys2Big W;
% Out of safe range, convert to BIGN
    ContinuableError(99, "Sys2Big cant convert Word to BIGNUM, no BIGNUM's loaded",
                          Sys2Int W);

on Syslisp;

CompileTime <<

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

expr procedure NameGen(Name,Part);
% Generate Nice specific name from Generic name 
    Intern Concat(ID2String Name,ID2String Part);

smacro procedure NextArg();
% Just substitute in the context of U
  <<U:=cdr U; car U>>;

smacro procedure Prologue();
% Common Prologue
<<  generic := NextArg();
    wgen := NextArg();
    fgen := NextArg();
    bgen := NextArg();
    hardgen := NameGen(generic,'!-Hardcase);
    Flag1(hardgen, 'NotYetInternalFunction);
>>;

macro procedure DefArith2Entry U;
begin scalar generic, wgen, fgen, bgen, hardgen;
    Prologue();
    return SublA(Pair('(GENERIC WGEN FGEN BGEN HARDGEN),
		      list(generic, wgen, fgen, bgen, hardgen)),
		 quote <<

expr procedure GENERIC(x,y);
    if Beta2P(x,y) then <<x:=WGEN(x,y);
		          If IntP x then x else Sys2Int x>>
      else HARDGEN(x, y);

expr procedure HARDGEN(x, y);
    case Coerce2(x, y, 'GENERIC) of
	POSINT:   Sys2Int WGEN(WGetV(ArithArg, 0), WGetV(ArithArg, 1));
	 %/ Beware of Overflow, WGEN maybe should test args
	 %/ Coerce2 is supposed to check this case
	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;
    Prologue();
    return SublA(Pair('(GENERIC WGEN FGEN BGEN HARDGEN),
		      list(generic, wgen, fgen, bgen, hardgen)),
		 quote <<

expr procedure GENERIC(x,y);
    if Beta2P(x,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));
%/ Assumes Preds are safe against Overflow
	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, fgen, bgen, hardgen;
    Prologue();	
    return SublA(Pair('(GENERIC WGEN BGEN HARDGEN),
		      list(generic, wgen, bgen, hardgen)),
		 quote <<

expr procedure GENERIC(x,y);
    if Beta2P(x,y) then <<x:=WGEN(x, y);
	                  if IntP x then x else Sys2Int x>>
     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;
    Prologue();
    return SublA(Pair('(GENERIC WGEN FGEN BGEN HARDGEN),
		      list(generic, wgen, fgen, bgen, hardgen)),
		 quote <<

expr procedure GENERIC x;
    if BetaP x then <<x:=WGEN x;
	              if IntP x then x else Sys2Int x>>
     else HARDGEN x;

expr procedure HARDGEN x;
    case Coerce1(x,'GENERIC) of
	POSINT:   Sys2Int WGEN WGetv(ArithArg,0);
	FLTN:     FGEN WGetv(ArithArg,0);
	BIGN:     BGEN WGetv(ArithArg,0);
        default:  NonNumber1Error(x,'GENERIC);
    end;

>>);
end;

macro procedure DefArithPred1Entry U;
begin scalar generic, wgen, fgen, bgen, hardgen;
    Prologue();
    return SublA(Pair('(GENERIC WGEN FGEN BGEN HARDGEN),
		      list(generic, wgen, fgen, bgen, hardgen)),
		 quote <<

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

expr procedure HARDGEN x;
    case Coerce1(x,'GENERIC) of
	POSINT:  WGEN Wgetv(ArithArg,0);
	FLTN:    FGEN Wgetv(ArithArg,0);
	BIGN:    BGEN Wgetv(ArithArg,0);
	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;

>>;

% The support procedures for coercing types

procedure Coerce1(X, F);
% Returns type tag of coerced X type and sets ArithArg[0] to be coerced X
% Beware of ADD1/SUB1 cases, maybe can optimize later
begin scalar T1;
    T1 := Tag X;
    case T1 of
	NEGINT:   T1 := POSINT;
	FIXN:    <<  T1 := POSINT;    X := FixVal FixInf X >>;
    end;
    If T1=POSINT and not BetaRangeP(x) then <<T1:=BIGN; x:=Sys2Big x>>;
    WPutv(ArithArg,0,X);
    return T1;
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;
    If T1=POSINT and not BetaRangeP(x) then <<T1:=BIGN; x:=Sys2Big x>>;
    T2 := Tag Y;
    case T2 of
	NEGINT:     T2 := POSINT;
	FIXN:   <<  T2 := POSINT;   Y := FixVal FixInf Y >>;
    end;
    If T2=POSINT and not BetaRangeP(Y) then <<T2:=BIGN; y:=Sys2Big y>>;
    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 NonNumber2Error(X,Y,F);
 % Here, since no 2 arg Arith Preds that accept 1 number, one not
    case T1 of
	FLTN:  case T2 of
		 POSINT:    @P := StaticIntFloat @P;
		 BIGN: 	    @P := FloatFromBignum @P;
	       end;
	BIGN:     @P := Sys2Big @P;	% @P must be SYSint
    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));

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


% Now generate the entries for each operator

DefArith2Entry(Plus2, WPlus2, FloatPlus2, BigPlus2);
DefFloatEntry(FloatPlus2, !*FPlus2);
DefArith2Entry(Difference, WDifference, FloatDifference, BigDifference);
DefFloatEntry(FloatDifference, !*FDifference);
DefArith2Entry(Times2, WTimes2, FloatTimes2, BigTimes2);
	 % Beware of Overflow 
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;
        procedure Fdummy(x,y);
          StdError "Fdummy should never be called";
DefInt2Entry(Remainder, WRemainder, Fdummy, BigRemainder);
DefInt2Entry(LAnd, WAnd, Fdummy, BigLAnd);
DefInt2Entry(LOr, WOr, Fdummy, BigLOr);
DefInt2Entry(LXOr, WXOr, Fdummy, BigLXOr);
% Cant DO Lshift in terms of BETA sized shifts
% Will toatlly redefine in BIG package
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:     FloatFromBigNum 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;

off Syslisp;

END;