Artifact b372c6aa47874a010af296a1301223364493db874bf79e09a63edf00b17922ab:

• File psl-1983/3-1/util/numeric-operators.sl — 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: 7279) [annotate] [blame] [check-ins using] [more...]

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Numeric-Operators.SL - Definitions of Numeric Operators with "Fast" Option
% 
% Author:      Alan Snyder
%              Hewlett-Packard/CRC
% Date:        7 January 1983 (based on the earlier Fast-Int module)
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% Edit by Cris Perdue,  7 Mar 1983 1131-PST
% Redefined + and * to take any number of arguments.
% This involved defining exprs fast-plus and fast-times.
% Added an error check to - and /

% WARNING: + and * are no longer exprs.  Code using this module and COMPILED
% with the fast-integers switch set to NIL will not work until it is
% recompiled. /csp

% Note: This must be LOAD, not IMPORTS.  Common also defines +, others. /csp
(BothTimes (load common useful))

% This file defines a set of C-like numeric operators that are a superset of the
% numeric operators defined by the Common Lisp compatibility package.

% The operators are:
%
%	=	Numeric Equal
%	/=	Numeric Not Equal (common lisp)
%	~=	Numeric Not Equal (CLU)
%	<	Numeric Less Than
%	>	Numeric Greater Than
%	<=	Numeric Less Than or Equal
%	>=	Numeric Greater Than or Equal
%	+	Numeric Addition
%	-	Numeric Minus or Subtraction
%	*	Numeric Multiplication
%	/	Numeric Division
%	//	Numeric Remainder
%	~	Integer Bitwise Logical Not
%	&	Integer Bitwise Logical And
%	|	Integer Bitwise Logical Or
%	^	Integer Bitwise Logical Xor
%	<<	Integer Bitwise Logical Left Shift
%	>>	Integer Bitwise Logical Right Shift

% +, -, *, and / are defined as in Common LISP, but when compiled they
% do open-coded arithmetic only, just like all the other operators.
% The arithmetic relational operators all take exactly 2 arguments,
% unlike the genuine Common LISP versions.

% The switch FAST-INTEGERS controls an option that provides for an efficient
% compiled implementation of these operators using Syslisp arithmetic.  When the
% switch is on, uses of these operators will compile into the corresponding
% Syslisp arithmetic operators, which generally are open-compiled and fast.
% However, the Syslisp operators perform machine arithmetic on untagged
% integers: they will work only if their inputs are untagged integers, and they
% produce untagged integer outputs.  The (undocumented) functions Int2Sys and
% Sys2Int can be used to convert between tagged Lisp integers and Syslisp
% integers; however, no conversion is needed to convert between INUMs and
% Syslisp integers within the valid range of INUMs.

% This module modifies the FOR macro to use the numeric operators to implement
% the FROM clause; thus, the FOR statement will use Syslisp arithmetic when the
% FAST-INTEGERS switch is on.

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% The Implementation:
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% Generic definitions of functions defined in the Common Lisp package:

(de = (a b) (EqN a b))
(de < (a b) (LessP a b))
(de > (a b) (GreaterP a b))
(de <= (a b) (LEq a b))
(de >= (a b) (GEq a b))

(defmacro + args
  (cond ((null args) 0)
	((null (rest args))
	 (first args))
	((null (cddr args))
	 `(fast-plus ,@args))
	(t (left-expand args 'fast-plus))))

(defmacro * args
  (cond ((null args) 1)
	((null (rest args))
	 (first args))
	((null (cddr args))
	 `(fast-times ,@args))
	(t (left-expand args 'fast-times))))

(defmacro - args
  (cond ((null args)
	 (stderror "No args supplied to ""-"""))
	((null (cdr args))
	 `(fast-minus ,@args))
        ((null (cddr args))
	 `(fast-difference ,@args))
	(t (left-expand args 'fast-difference))))

(defmacro / args
  (cond ((null args)
	 (stderror "No args supplied to ""/"""))
	((null (cdr args))
	 `(recip ,(car args)))
        ((null (cddr args))
	 `(fast-quotient ,@args))
	(t (left-expand args 'fast-quotient))))

% Generic definitions of functions not defined by the Common Lisp package:

(de ~= (a b) (not (EqN a b)))
(de fast-plus (a b) (Plus a b))
(de fast-times (a b) (Times a b))
(de fast-minus (a) (Minus a))
(de fast-difference (a b) (Difference a b))
(de fast-quotient (a b) (Quotient a b))
(de // (a b) (Remainder a b))
(de ~ (a) (LNot a))
(de & (a b) (LAnd a b))
(de | (a b) (LOr a b))
(de ^ (a b) (LXor a b))
(de << (a b) (LShift a b))
(de >> (a b) (LShift a (Minus b)))

% Enable and Disable "fast" compiled definitions:

(fluid '(*fast-integers))
(put 'fast-integers 'simpfg '((T (enable-fast-numeric-operators))
			       (NIL (disable-fast-numeric-operators))
			       ))

(de enable-fast-numeric-operators ()
  (put '= 'cmacro '(lambda (a b) (WEQ a b)))
  (put '/= 'cmacro '(lambda (a b) (WNEQ a b)))
  (put '~= 'cmacro '(lambda (a b) (WNEQ a b)))
  (put '< 'cmacro '(lambda (a b) (WLessP a b)))
  (put '> 'cmacro '(lambda (a b) (WGreaterP a b)))
  (put '<= 'cmacro '(lambda (a b) (WLEQ a b)))
  (put '>= 'cmacro '(lambda (a b) (WGEQ a b)))
  (put 'fast-plus 'cmacro '(lambda (a b) (WPlus2 a b)))
  (put 'fast-difference 'cmacro '(lambda (a b) (WDifference a b)))
  (put 'fast-minus 'cmacro '(lambda (a) (WDifference 0 a)))
  (put 'fast-times 'cmacro '(lambda (a b) (WTimes2 a b)))
  (put 'fast-quotient 'cmacro '(lambda (a b) (WQuotient a b)))
  (put '// 'cmacro '(lambda (a b) (WRemainder a b)))
  (put '~ 'cmacro '(lambda (a) (WNot a)))
  (put '& 'cmacro '(lambda (a b) (WAnd a b)))
  (put '| 'cmacro '(lambda (a b) (WOr a b)))
  (put '^ 'cmacro '(lambda (a b) (WXor a b)))
  (put '<< 'cmacro '(lambda (a b) (WShift a b)))
  (put '>> 'cmacro '(lambda (a b) (WShift a (WDifference 0 b))))
  )

(de disable-fast-numeric-operators ()
  (remprop '= 'cmacro)
  (remprop '/= 'cmacro)
  (remprop '~= 'cmacro)
  (remprop '< 'cmacro)
  (remprop '> 'cmacro)
  (remprop '<= 'cmacro)
  (remprop '>= 'cmacro)
  (remprop '+ 'cmacro)
  (remprop 'fast-difference 'cmacro)
  (remprop 'fast-minus 'cmacro)
  (remprop '* 'cmacro)
  (remprop 'fast-quotient 'cmacro)
  (remprop '// 'cmacro)
  (remprop '~ 'cmacro)
  (remprop '& 'cmacro)
  (remprop '| 'cmacro)
  (remprop '^ 'cmacro)
  (remprop '<< 'cmacro)
  (remprop '>> 'cmacro)
  )

% Here we redefine the FROM clause of FOR statements:

(fluid '(for-vars* for-outside-vars* for-tests* for-prologue* for-conditions*
		   for-body* for-epilogue* for-result*))

(de for-from-function (clause)
  (let* ((var (car clause))
	 (var1 (if (pairp var) (car var) var))
	 (clause (cdr clause))
	 (init (if (pairp clause) (or (pop clause) 1) 1))
	 (fin (if (pairp clause) (pop clause) nil))
	 (fin-var (if (and fin (not (numberp fin))) (gensym) nil))
	 (step (if (pairp clause) (car clause) 1))
	 (step-var (if (and step (not (numberp step))) (gensym) nil)))
    (tconc
     for-vars*
     (list* var init (cond
		      (step-var `((+ ,var1 ,step-var)))
		      ((zerop step) nil)
		      ((onep step) `((+ ,var1 1)))
		      ((eqn step -1) `((- ,var1 1)))
		      (t `((+ ,var1 ,step))))))
    (if fin-var (tconc for-vars* `(,fin-var ,fin)))
    (if step-var (tconc for-vars* `(,step-var ,step)))
    (cond (step-var
	   (tconc for-tests* `(if (< ,step-var 0)
				(< ,var1 ,(or fin-var fin))
				(> ,var1 ,(or fin-var fin)))))
	  ((null fin))
	  ((minusp step) (tconc for-tests* `(< ,var1 ,(or fin-var fin))))
	  (t (tconc for-tests* `(> ,var1 ,(or fin-var fin)))))))