File psl-1983/3-1/util/nbarith.red artifact 30832500cb part of check-in 5f584e9b52


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


REDUCE Historical
REDUCE Sourceforge Project | Historical SVN Repository | GitHub Mirror | SourceHut Mirror | NotABug Mirror | Chisel Mirror | Chisel RSS ]