Changeset 6748

Timestamp:

Jun 16, 2007, 7:18:58 PM (17 years ago)

Author:

Gary Byers

Message:

No constraints on cocoa-defaults. Add optional change-hook mechanism.

File:

• branches/ide-1.0/ccl/examples/cocoa-defaults.lisp (modified) (8 diffs)

branches/ide-1.0/ccl/examples/cocoa-defaults.lisp

@@ -29 +29 @@
   value                                 ; the "standard" initial value
   doc                                   ; a doc string
-  constraint                            ; an optional type constraint.
+  change-hook                           ; an optional hook function
   )
 
@@ -43 +43 @@
   (defun %clear-cocoa-defaults () (setq cocoa-defaults nil)))
 
-(defun set-cocoa-default (name string type value doc &optional constraint)
+(defun set-cocoa-default (name string type value doc &optional change-hook)
   (check-type name symbol)
   (check-type string objc-constant-string)
@@ -54 +54 @@
                                           :value value
                                           :doc doc
-                                          :constraint constraint))
+                                          :change-hook change-hook))
   value)
 
@@ -62 +62 @@
   
 
-(defun %define-cocoa-default (name type value doc &optional constraint)
+(defun %define-cocoa-default (name type value doc &optional change-hook)
   (proclaim `(special ,name))
   ;; Make the variable "GLOBAL": its value can be changed, but it can't
@@ -70 +70 @@
   (record-source-file name 'variable)
   (setf (documentation name 'variable) doc)
-  (set name (set-cocoa-default name (objc-default-key name) type value doc constraint))
+  (set name (set-cocoa-default name (objc-default-key name) type value doc change-hook))
   name)
   
   
 
-(defmacro def-cocoa-default (name type value  doc &optional constraint &environment env)
+(defmacro def-cocoa-default (name type value  doc &optional change-hook &environment env)
   `(progn
      (eval-when (:compile-toplevel)
        (note-variable-info ',name :global ,env))
     (declaim (special ,name))
-    (%define-cocoa-default ',name  ',type ,value ',doc ,@(when constraint `((specifier-type ',constraint))))))
+    (defloadvar ,name nil)
+    (%define-cocoa-default ',name  ',type ,value ',doc ,change-hook)))
 
     
@@ -94 +95 @@
              (key (objc-constant-string-nsstringptr (cocoa-default-string d))))
         (if (%null-ptr-p (#/objectForKey:  domain key))
-          (progn
-            (#/setObject:forKey: domain
-                                 (case (cocoa-default-type d)
-                                   (:color (#/archivedDataWithRootObject:
+          (let* ((value (cocoa-default-value d)))
+            (case (cocoa-default-type d)
+              (:int (#/setInteger:forKey: domain value key))
+              (:float (#/setFloat:forKey: domain value key))
+              (:bool (#/setBool:forKey: domain value key))
+              (:color (#/setObject:forKey: domain
+                                           (#/archivedDataWithRootObject:
                                             ns:ns-archiver
-                                            (cocoa-default-value d)))
-                                   (t
-                                    (%make-nsstring (format nil "~a" (cocoa-default-value d)))))
-                                   key)
+                                            value)
+                                           key))
+              (t 
+               (#/setObject:forKey: domain
+                                    (%make-nsstring (format nil "~a" (cocoa-default-value d)))
+
+                                    key)))
             (setq need-synch t))
-          (case (cocoa-default-type d)
-            (:int
-             (set name (#/integerForKey: domain key)))
-            (:float
-             (set name (#/floatForKey: domain key)))
-            (:string
-             (let* ((nsstring (#/stringForKey: domain key)))
-               (unless (%null-ptr-p nsstring)
-                 (set name (lisp-string-from-nsstring nsstring)))))
-            (:color
-             (let* ((data (#/dataForKey: domain key)))
-               (unless (%null-ptr-p data)
-                 (set name (#/retain (#/unarchiveObjectWithData: ns:ns-unarchiver data))))))))))
+          (let* ((hook (cocoa-default-change-hook d))
+                 (old-value (symbol-value name)))
+            (case (cocoa-default-type d)
+              (:int
+               (set name (#/integerForKey: domain key)))
+              (:float
+               (set name (#/floatForKey: domain key)))
+              (:bool
+               (set name (#/boolForKey: domain key)))
+              (:string
+               (let* ((nsstring (#/stringForKey: domain key)))
+                 (unless (%null-ptr-p nsstring)
+                   (set name (lisp-string-from-nsstring nsstring)))))
+              (:color
+               (let* ((data (#/dataForKey: domain key)))
+                 (unless (%null-ptr-p data)
+                   (set name (#/retain (#/unarchiveObjectWithData: ns:ns-unarchiver data)))))))
+            (when hook (funcall hook old-value (symbol-value name)))))))
     (when need-synch (#/synchronize domain))))
 
@@ -125 +137 @@
             (:int
              (set name (#/intValue newval)))
+            (:bool
+             (#_NSLog #@"newvalue = %@" :id newval)
+             (set name (coerce-from-bool (#/intValue newval))))
             (:float
              (set name (#/floatValue newval)))
@@ -140 +155 @@
                               :with-capacity (length defaults))))
     (dolist (d defaults dict)
+      (let* ((value (cocoa-default-value d)))
       (#/setObject:forKey: dict
                            (case (cocoa-default-type d)
                              (:color (#/archivedDataWithRootObject:
                                       ns:ns-archiver
-                                      (cocoa-default-value d)))
+                                      value))
+                             (:int (make-instance 'ns:ns-number
+                                                  :with-int value))
+                             (:float (make-instance 'ns:ns-number
+                                                    :with-float value))
+                             (:bool (make-instance 'ns:ns-number
+                                                   :with-bool (coerce-to-bool value)))
                              (t
                               (%make-nsstring (format nil "~a" (cocoa-default-value d)))))
-                           (objc-constant-string-nsstringptr (cocoa-default-string d))))))
+                           (objc-constant-string-nsstringptr (cocoa-default-string d)))))))