;;; This is a -*-Lisp-*- file.
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; Spice Lisp is currently incomplete and under active development.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;; Arithmetic functions for Spice Lisp.
;;; These functions are part of the standard Spice Lisp environment.
;;; Written by Jim Large
;;; Modified by Scott Fahlman
;;; Updated by Walter van Roggen, November 1982
;;; *******************************************************************
;;; Predicates, excluding type predicates
(defun zerop (number)
"Returns T if number = 0, NIL otherwise."
(zerop number))
(defun plusp (number)
"Returns T if number > 0, NIL otherwise."
(plusp number))
(defun minusp (number)
"Returns T if number < 0, NIL otherwise."
(minusp number))
(defun oddp (number)
"Returns T if number is odd, NIL otherwise."
(oddp number))
(defun evenp (number)
"Returns T if number is even, NIL otherwise."
(evenp number))
;;; Comparisons
(defun = (number &rest more-numbers)
"Returns T if all of its arguments are numerically equal, NIL otherwise."
(do ((nlist more-numbers (cdr nlist)))
((atom nlist) T)
(declare (list nlist))
(if (not (= (car nlist) number)) (return nil))))
(defun /= (number &rest more-numbers)
"Returns T if no two of its arguments are numerically equal, NIL otherwise."
(do* ((head number (car nlist))
(nlist more-numbers (cdr nlist)))
((atom nlist) t)
(declare (list nlist))
(unless (do* ((nl nlist (cdr nl)))
((atom nl) T)
(declare (list nl))
(if (= head (car nl)) (return nil)))
(return nil))))
(defun < (number &rest more-numbers)
"Returns T if its arguments are in strictly increasing order, NIL otherwise."
(do* ((n number (car nlist))
(nlist more-numbers (cdr nlist)))
((atom nlist) t)
(declare (list nlist))
(if (not (< n (car nlist))) (return nil))))
(defun > (number &rest more-numbers)
"Returns T if its arguments are in strictly decreasing order, NIL otherwise."
(do* ((n number (car nlist))
(nlist more-numbers (cdr nlist)))
((atom nlist) t)
(declare (list nlist))
(if (not (> n (car nlist))) (return nil))))
(defun <= (number &rest more-numbers)
"Returns T if arguments are in strictly non-decreasing order, NIL otherwise."
(do* ((n number (car nlist))
(nlist more-numbers (cdr nlist)))
((atom nlist) t)
(declare (list nlist))
(if (not (<= n (car nlist))) (return nil))))
(defun >= (number &rest more-numbers)
"Returns T if arguments are in strictly non-increasing order, NIL otherwise."
(do* ((n number (car nlist))
(nlist more-numbers (cdr nlist)))
((atom nlist) t)
(declare (list nlist))
(if (not (>= n (car nlist))) (return nil))))
(defun max (number &rest more-numbers)
"Returns the greatest of its arguments."
(do ((nlist more-numbers (cdr nlist))
(result number))
((null nlist) (return result))
(declare (list nlist))
(if (> (car nlist) result) (setq result (car nlist)))))
(defun min (number &rest more-numbers)
"Returns the least of its arguments."
(do ((nlist more-numbers (cdr nlist))
(result number))
((null nlist) (return result))
(declare (list nlist))
(if (< (car nlist) result) (setq result (car nlist)))))
;;; Arithmetic Operations
;;; Doesn't bug out automatically, as a straight recursive version would.
;;; (i.e. (+ 1.0 2.0) <=> (+ 0 1.0 2.0))
(defmacro define-arith (op init doc)
`(defun ,op (&rest args)
,doc
(if (null args) ,init
(do ((args (cdr args) (cdr args))
(res (car args) (,op res (car args))))
((null args) res)))))
(define-arith + 0
"Returns the sum of its arguments. With no args, returns 0.")
(define-arith * 1
"Returns the product of its arguments. With no args, returns 1.")
(defun - (number &rest more-numbers)
"Subtracts the second and all subsequent arguments from the first.
With one arg, negates it."
(if more-numbers
(do ((nlist more-numbers (cdr nlist))
(result number))
((atom nlist) result)
(declare (list nlist))
(setq result (- result (car nlist))))
(- number)))
(defun / (number &rest more-numbers)
"Divides the first arg by each of the following arguments, in turn.
With one arg, returns reciprocal."
(if more-numbers
(do ((nlist more-numbers (cdr nlist))
(result number))
((atom nlist) result)
(declare (list nlist))
(setq result (/ result (car nlist))))
(/ number)))
(defun 1+ (number)
"Returns NUMBER + 1."
(1+ number))
(defun 1- (number)
"Returns NUMBER - 1."
(1- number))
;;; Note: INCF and DECF are defined in the MACROS file.
(defun conjugate (number)
"Returns the complex conjugate of NUMBER. For non-complex numbers, this is
an identity."
(if (typep number 'complex)
(complex (realpart number) (- (imagpart number)))
number))
;;; Note: GCD and LCM are defined in the implementation dependent NUM file.
;;; Note: Transcendental and trig functions are in a file of their own.
(defun abs (number)
"Returns the absolute value of the number."
(abs number))
(defun phase (number)
"Returns the angle part of the polar representation of a complex number.
For non-complex numbers, this is 0."
(if (complexp number)
(atan (realpart number) (imagpart number))
0))
(defun signum (number)
"If NUMBER is zero, return NUMBER, else return (/ NUMBER (ABS NUMBER)).
Currently not implemented for complex numbers."
(if (zerop number)
number
(if (rationalp number)
(if (plusp number) 1 -1)
(/ number (abs number)))))
;;; Type conversions.
(defun float (number &optional (other () otherp))
"Converts a number of any type to floating point.
If OTHER is not provided, it returns a SINGLE-FLOAT if NUMBER
is not already a FLOAT. If OTHER is provided, the result is
the same float format as OTHER."
(if otherp
(typecase other
(short-float (%sp-short-float number))
(single-float (%sp-single-float number))
(double-float (%sp-double-float number))
(long-float (%sp-long-float number))
(t (error "~S is not a floating point number." other) ))
(if (floatp number)
number
(%sp-single-float number))))
;;; Note: RATIONAL and RATIONALIZE are in the implementation dependent NUM files
(defun floor (number &optional (divisor 1))
"Returns the greatest integer not greater than number, or number/divisor.
The second returned value is (mod number divisor)."
(multiple-value-bind (tru rem) (truncate number divisor)
(if (or (and (minusp tru) (not (zerop rem)))
(and (zerop tru)
(or (and (minusp number) (plusp divisor))
(and (not (minusp number)) (minusp divisor)))))
(values (- tru 1) (+ rem divisor))
(values tru rem))))
(defun ceiling (number &optional (divisor 1))
"Returns the smallest integer not less than number, or number/divisor.
The second returned value is the remainder."
(multiple-value-bind (tru rem) (truncate number divisor)
(if (or (and (plusp tru) (not (zerop rem)))
(and (zerop tru)
(or (and (minusp number) (minusp divisor))
(and (plusp number) (plusp divisor)))))
(values (+ tru 1) (- rem divisor))
(values tru rem))))
(defun truncate (number &optional (divisor 1))
"Returns number (or number/divisor) as an integer, rounded toward 0.
The second returned value is the remainder."
(truncate number divisor))
(defun round (number &optional (divisor 1 divp) &aux thresh)
"Rounds number (or number/divisor) to nearest integer.
The second returned value is the remainder."
(multiple-value-bind (tru rem) (truncate number divisor)
(if divp
(setq thresh (/ (abs divisor) 2))
(setq thresh 0.5))
(cond ((or (> rem thresh)
(and (= rem thresh) (oddp tru)))
(values (+ tru 1) (- rem divisor)))
((or (< rem (- thresh))
(and (= rem (- thresh)) (oddp tru)))
(values (- tru 1) (+ rem divisor)))
(t (values tru rem)))))
(defun mod (number divisor)
"Returns second result of FLOOR."
(multiple-value-bind (tru rem) (truncate number divisor)
(if (or (and (minusp tru) (not (zerop rem)))
(and (zerop tru)
(or (and (minusp number) (plusp divisor))
(and (not (minusp number)) (minusp divisor)))))
(+ rem divisor)
rem)))
(defun rem (number divisor)
"Returns second result of TRUNCATE."
(multiple-value-bind (tru rem) (truncate number divisor)
(declare (ignore tru))
rem))
(defun ffloor (number &optional (divisor 1))
"Same as FLOOR, but returns first value as a float."
(multiple-value-bind (flr rem) (floor number divisor)
(values (float flr) rem)))
(defun fceiling (number &optional (divisor 1))
"Same as CEILING, but returns first value as a float."
(multiple-value-bind (cei rem) (ceiling number divisor)
(values (float cei) rem)))
(defun ftruncate (number &optional (divisor 1))
"Same as TRUNCATE, but returns first value as a float."
(multiple-value-bind (tru rem) (truncate number divisor)
(values (float tru) rem)))
(defun fround (number &optional (divisor 1))
"Same as ROUND, but returns first value as a float."
(multiple-value-bind (rou rem) (round number divisor)
(values (float rou) rem)))
;;; Component extractions on numbers
;;; FLOAT-SIGNIFICAND, FLOAT-EXPONENT, SCALE-FLOAT, FLOAT-RADIX, and
;;; FLOAT-SIGN are defined in the implementation dependent NUM file.
(defun complex (realpart &optional (imagpart 0))
"Builds a complex number. Currently, complex numbers are not supported."
(error "Complex numbers are not yet implemented.")
(if (complexp realpart)
(error "~S is a complex number." realpart))
(if (complexp imagpart)
(error "~S is a complex number." imagpart))
(let ((x (%sp-alloc-complex)))
(%sp-svset x %complex-real-part-slot realpart)
(%sp-svset x %complex-imaginary-part-slot imagpart)
x))
(defun realpart (number)
"Extracts the real part of a number."
(if (complexp number)
(%sp-svref number %complex-real-part-slot)
number))
(defun imagpart (number)
"Extracts the imaginary part of a number."
(typecase number
(complex
(%sp-svref number %complex-imaginary-part-slot))
(number (coerce 0 (type-of number)))
(t (error "~S not a number." number))))
;;; Bit-wise logical functions map integers onto integers
(defun logior (&rest integers)
"Returns the bit-wise or of its arguments. Args must be integers."
(declare (list integers))
(if integers
(do* ((result (pop integers) (logior result (pop integers))))
((null integers) result))
0))
(defun logxor (&rest integers)
"Returns the bit-wise exclusive or of its arguments. Args must be integers."
(declare (list integers))
(if integers
(do* ((result (pop integers) (logxor result (pop integers))))
((null integers) result))
0))
(defun logand (&rest integers)
"Returns the bit-wise and of its arguments. Args must be integers."
(declare (list integers))
(if integers
(do* ((result (pop integers) (logand result (pop integers))))
((null integers) result))
-1))
(defun logeqv (&rest integers)
"Returns the bit-wise equivalence of its arguments. Args must be integers."
(declare (list integers))
(if integers
(do* ((result (pop integers) (logeqv result (pop integers))))
((null integers) result))
-1))
(defun lognand (integer1 integer2)
"Returns the complement of the logical AND of integer1 and integer2."
(lognand integer1 integer2))
(defun lognor (integer1 integer2)
"Returns the complement of the logical OR of integer1 and integer2."
(lognor integer1 integer2))
(defun logandc1 (integer1 integer2)
"Returns the logical AND of (LOGNOT integer1) and integer2."
(logandc1 integer1 integer2))
(defun logandc2 (integer1 integer2)
"Returns the logical AND of integer1 and (LOGNOT integer2)."
(logandc2 integer1 integer2))
(defun logorc1 (integer1 integer2)
"Returns the logical OR of (LOGNOT integer1) and integer2."
(logorc1 integer1 integer2))
(defun logorc2 (integer1 integer2)
"Returns the logical OR of integer1 and (LOGNOT integer2)."
(logorc2 integer1 integer2))
(defun lognot (number)
"Returns the bit-wise logical not of integer."
(lognot number))
;;; The boole function dispaches to any of the above operations depending on
;;; the value of a variable. Presently, legal selector values are [0..15].
;;; boole is open coded for calls with a constant selector. or with calls
;;; using any of the constants declared below.
(defconstant boole-clr 0
"Boole function op, makes BOOLE return 0.")
(defconstant boole-set 1
"Boole function op, makes BOOLE return -1.")
(defconstant boole-1 2
"Boole function op, makes BOOLE return integer1.")
(defconstant boole-2 3
"Boole function op, makes BOOLE return integer2.")
(defconstant boole-c1 4
"Boole function op, makes BOOLE return complement of integer1.")
(defconstant boole-c2 5
"Boole function op, makes BOOLE return complement of integer2.")
(defconstant boole-and 6
"Boole function op, makes BOOLE return logand of integer1 and integer2.")
(defconstant boole-ior 7
"Boole function op, makes BOOLE return logior of integer1 and integer2.")
(defconstant boole-xor 8
"Boole function op, makes BOOLE return logxor of integer1 and integer2.")
(defconstant boole-eqv 9
"Boole function op, makes BOOLE return logeqv of integer1 and integer2.")
(defconstant boole-nand 10
"Boole function op, makes BOOLE return log nand of integer1 and integer2.")
(defconstant boole-nor 11
"Boole function op, makes BOOLE return lognor of integer1 and integer2.")
(defconstant boole-andc1 12
"Boole function op, makes BOOLE return logandc1 of integer1 and integer2.")
(defconstant boole-andc2 13
"Boole function op, makes BOOLE return logandc2 of integer1 and integer2.")
(defconstant boole-orc1 14
"Boole function op, makes BOOLE return logorc1 of integer1 and integer2.")
(defconstant boole-orc2 15
"Boole function op, makes BOOLE return logorc2 of integer1 and integer2.")
(defun boole (op integer1 integer2)
"Bit-wise boolean function on two integers. Function chosen by OP (see manual)"
(case op
(0 (boole 0 integer1 integer2))
(1 (boole 1 integer1 integer2))
(2 (boole 2 integer1 integer2))
(3 (boole 3 integer1 integer2))
(4 (boole 4 integer1 integer2))
(5 (boole 5 integer1 integer2))
(6 (boole 6 integer1 integer2))
(7 (boole 7 integer1 integer2))
(8 (boole 8 integer1 integer2))
(9 (boole 9 integer1 integer2))
(10 (boole 10 integer1 integer2))
(11 (boole 11 integer1 integer2))
(12 (boole 12 integer1 integer2))
(13 (boole 13 integer1 integer2))
(14 (boole 14 integer1 integer2))
(15 (boole 15 integer1 integer2))
(t (error "~S is not of type (mod 16)." op))))
;;; Bit testing, Shifting, and assorted logcal operations
(defun logtest (integer1 integer2)
"Predicate which returns T if logand of integer1 and integer2 is not zero."
(logtest integer1 integer2))
(defun logbitp (index integer)
"Predicate returns T if bit index of integer is a 1."
(logbitp index integer))
(defun ash (integer count)
"Shifts integer left by count places preserving sign. - count shifts right."
(ash integer count))
(defun logcount (integer)
"If INTEGER is negative, then # of 0 bits is returned,
else # of 1 bits is returned."
(let ((total 0))
(if (minusp integer)
(dotimes (i (integer-length integer))
(if (not (logbitp i integer)) (incf total)))
(dotimes (i (integer-length integer))
(if (logbitp i integer) (incf total))))
total))
(defun integer-length (integer)
"Returns the number of significant bits in the absolute value of integer."
(integer-length integer))
;;; Byte manipulation functions operate on fields within integers.
(defun byte (size position)
"Returns a byte specifier which may be used by other byte functions."
(byte size position))
(defun byte-size (bytespec)
"Returns the size part of the byte specifier bytespec."
(byte-size bytespec))
(defun byte-position (bytespec)
"Returns the position part of the byte specifier bytespec."
(byte-position bytespec))
(defun ldb (bytespec integer)
"Extract the specified byte from integer, and right justify result."
(ldb bytespec integer))
(defun ldb-test (bytespec integer)
"Returns T if any of the specified bits in integer are 1's."
(ldb-test bytespec integer))
(defun mask-field (bytespec integer)
"Extract the specified byte from integer, but do not right justify result."
(mask-field bytespec integer))
(defun dpb (newbyte bytespec integer)
"Returns new integer with newbyte in specified position, newbyte is right justified."
(dpb newbyte bytespec integer))
(defun deposit-field (newbyte bytespec integer)
"Returns new integer with newbyte in specified position, newbyte is not right justified."
(deposit-field newbyte bytespec integer))