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