Fix bug in read-symbol

[jscl.git] / src / numbers.lisp

diff --git a/src/numbers.lisp b/src/numbers.lisp
index 24882b7..18d679c 100644 (file)
--- a/src/numbers.lisp
+++ b/src/numbers.lisp
@@ -16,19 +16,64 @@
 ;;;; Various numeric functions and constants
 
 ;; TODO: Use MACROLET when it exists
+(defmacro define-variadic-op (operator initial-value)
+  (let ((init-sym   (gensym))
+        (dolist-sym (gensym)))
+    `(defun ,operator (&rest args)
+       (let ((,init-sym ,initial-value))
+         (dolist (,dolist-sym args)
+           (setq ,init-sym (,operator ,init-sym ,dolist-sym)))
+         ,init-sym))))
+
+(define-variadic-op + 0)
+(define-variadic-op * 1)
+
+;; - and / work differently from the above macro.
+;; If only one arg is given, it negates it or takes its reciprocal.
+;; Otherwise all the other args are subtracted from or divided by it.
+;; TODO: Use MACROLET when it exists
+(defmacro define-sub-or-div (operator unary-form)
+  `(defun ,operator (x &rest args)
+     (cond
+       ((null args) ,unary-form)
+       (t (dolist (y args)
+            (setq x (,operator x y)))
+          x))))
+
+(define-sub-or-div - (-   x))
+(define-sub-or-div / (/ 1 x))
+
+(defun 1+ (x) (+ x 1))
+(defun 1- (x) (- x 1))
+
+(defun truncate (x &optional (y 1))
+  (floor (/ x y)))
+
+(defun integerp (x)
+  (and (numberp x) (= (floor x) x)))
+
+(defun floatp (x)
+  (and (numberp x) (not (integerp x))))
+
+(defun minusp (x) (< x 0))
+(defun zerop (x) (= x 0))
+(defun plusp (x) (< 0 x))
+
+;; TODO: Use MACROLET when it exists
 (defmacro defcomparison (operator)
   `(defun ,operator (x &rest args)
-     (while (not (null args))
-       (if (,operator x (car args))
-         (setq x    (car args)
-               args (cdr args))
+     (dolist (y args) 
+       (if (,operator x y)
+         (setq x    (car args))
          (return-from ,operator nil)))
      t))
 
 (defcomparison >)
 (defcomparison >=)
+(defcomparison =) 
 (defcomparison <)
 (defcomparison <=)
+(defcomparison /=)
 
 (defconstant pi 3.141592653589793) 
 
@@ -36,11 +81,8 @@
 (defun oddp  (x) (not (evenp x)))
 
 (flet ((%max-min (x xs func)
-         (while (not (null xs))
-           (setq x  (if (funcall func x (car xs))
-                      x
-                      (car xs))
-                 xs (cdr xs)))
+         (dolist (y xs) 
+           (setq x  (if (funcall func x (car xs)) x y)))
          x))
   (defun max (x &rest xs) (%max-min x xs #'>))
   (defun min (x &rest xs) (%max-min x xs #'<)))