r8073: add def-cached-vector

diff --git a/color.lisp b/color.lisp
index 11f809eb33094e3e341acb9c329342fd3129d2a3..d674886165f061ffa5424ad2f037305339bfd65c 100644 (file)
--- a/color.lisp
+++ b/color.lisp
@@ -268,7 +268,7 @@
     (when (<= (abs (- v1 v2)) value-range)\r
       t))\r
    (t\r
-    (when (and (<= (hue-difference-fixnum h1 h2) hue-range)\r
+    (when (and (<= (abs (hue-difference-fixnum h1 h2)) hue-range)\r
                (<= (abs (- v1 v2)) value-range)\r
                (<= (abs (- s1 s2)) saturation-range))\r
       t))))\r
@@ -277,7 +277,12 @@
    \r
 (defun hue-difference (h1 h2)\r
   "Return difference between two hues around 360 degree circle"\r
-  (when (and h1 h2)\r
+  (cond\r
+   ((and (null h1) (null h2))\r
+    t)\r
+   ((or (null h1) (null h2))\r
+    360)\r
+   (t\r
     (let ((diff (- h2 h1)))\r
       (cond\r
        ((< diff -180)\r
@@ -286,12 +291,17 @@
        ((> diff 180)\r
         (- (- 360 diff)))\r
        (t\r
-        diff)))))\r
+        diff))))))\r
  \r
   \r
 (defun hue-difference-fixnum (h1 h2)\r
   "Return difference between two hues around 360 degree circle"\r
-  (when (and h1 h2)\r
+  (cond\r
+   ((and (null h1) (null h2))\r
+    t)\r
+   ((or (null h1) (null h2))\r
+    360)\r
+   (t\r
     (locally (declare (type fixnum h1 h2))\r
       (let ((diff (- h2 h1)))\r
         (cond\r
@@ -301,5 +311,5 @@
          ((> diff 180)\r
           (- (- 360 diff)))\r
          (t\r
-          diff))))))\r
- 
\ No newline at end of file
+          diff)))))))\r
+ \r

diff --git a/macros.lisp b/macros.lisp
index 835c6d91bcac3cffabaf49d425fe1a623a02c1d6..5b7286590fa0e18647629f14171e3ffdb3c99a5c 100644 (file)
--- a/macros.lisp
+++ b/macros.lisp
@@ -187,3 +187,31 @@
       ,@(when docp
              `((setf (documentation ',var 'variable) ,doc)))
       (define-symbol-macro ,var ,backing-var))))
+
+(defmacro def-cached-vector (name element-type)
+  (let ((get-name (concat-symbol "get-" name "-vector"))
+       (release-name (concat-symbol "release-" name "-vector"))
+       (table-name (concat-symbol "*cached-" name "-table*"))
+       (lock-name (concat-symbol "*cached-" name "-lock*")))
+    `(eval-when (:compile-toplevel :load-toplevel :execute)
+       (defvar ,table-name (make-hash-table :test 'equal))
+       (defvar ,lock-name (kmrcl::make-lock ,name))
+        
+        (defun ,get-name (size)
+          (kmrcl::with-lock-held (,lock-name)
+            (let ((buffers (gethash (cons size ,element-type) ,table-name)))
+              (if buffers
+                  (let ((buffer (pop buffers)))
+                    (setf (gethash (cons size ,element-type) ,table-name) buffers)
+                    buffer)
+                (make-array size :element-type ,element-type)))))
+        
+        (defun ,release-name (buffer)
+          (kmrcl::with-lock-held (,lock-name)
+            (let ((buffers (gethash (cons (array-total-size buffer)
+                                          ,element-type)
+                                    ,table-name)))
+              (setf (gethash (cons (array-total-size buffer)
+                                   ,element-type) ,table-name)
+                (cons buffer buffers))))))))
+

diff --git a/package.lisp b/package.lisp
index 2edc6dacfcb50da46f812c5a600b7177987e12a0..dd95e3c75e6bf36d4742db348ac93baaaff66faf 100644 (file)
--- a/package.lisp
+++ b/package.lisp
@@ -131,6 +131,7 @@
    #:mac
    #:mv-bind
    #:deflex
+   #:def-cached-vector
    
    ;; files.lisp
    #:print-file-contents