[mcclim-cvs] CVS mcclim/ESA

[thenriksen]

Update of /project/mcclim/cvsroot/mcclim/ESA
In directory clnet:/tmp/cvs-serv12937/ESA

Modified Files:
	packages.lisp utils.lisp 
Log Message:
Changed the update-syntax protocol to use a nonstandard method
combination for added job security.


--- /project/mcclim/cvsroot/mcclim/ESA/packages.lisp	2008/01/01 18:43:36	1.9
+++ /project/mcclim/cvsroot/mcclim/ESA/packages.lisp	2008/01/07 22:01:59	1.10
@@ -44,6 +44,7 @@
            #:subtype-compatible-p
            #:capitalize
            #:ensure-array-size
+           #:values-max-min
            #:observable-mixin
            #:add-observer #:remove-observer
            #:observer-notified #:notify-observers
--- /project/mcclim/cvsroot/mcclim/ESA/utils.lisp	2008/01/01 18:43:36	1.6
+++ /project/mcclim/cvsroot/mcclim/ESA/utils.lisp	2008/01/07 22:01:59	1.7
@@ -233,6 +233,34 @@
          do (setf (elt array i) (funcall new-elem-fn)))))
   array)
 
+(define-method-combination values-max-min
+    (&optional (order ':most-specific-last))
+  ((around (:around))
+   (before (:before))
+   (after (:after))
+   (primary (values-max-min) :order order :required t))
+  (flet ((call-methods (methods)
+	   (mapcar (lambda (m) `(call-method ,m)) methods))
+	 (call-vmm-methods (methods)
+	   `(multiple-value-bind (max min)
+	        (call-method ,(first methods))
+              (progn
+                ,@(loop for m in (rest methods)
+                     collect `(multiple-value-bind (mmax mmin)
+                                  (call-method ,m)
+                                (setq max (max max mmax)
+                                      min (min min mmin)))))
+              (values max min))))
+    (let ((form (if (or around before after (rest primary))
+		    `(multiple-value-prog1 
+                         (progn ,@(call-methods before)
+                                ,(call-vmm-methods primary))
+                       (progn ,@(call-methods (reverse after))))
+		    `(call-method ,(first primary)))))
+      (if around
+	  `(call-method ,(first around) (,@(rest around) (make-method ,form)))
+	  form))))
+
 (defclass observable-mixin ()
   ((%observers :accessor observers
                :initform '()))