source: trunk/cocoa-ide-contrib/krueger/InterfaceProjects/Utilities/ns-object-utils.lisp @ 14637

Last change on this file since 14637 was 14637, checked in by plkrueger, 9 years ago

New example for App Developer Tools

File size: 45.7 KB
Line 
1;; ns-object-utils.lisp
2#|
3The MIT license.
4
5Copyright (c) 2010 Paul L. Krueger
6
7Permission is hereby granted, free of charge, to any person obtaining a copy of this software
8and associated documentation files (the "Software"), to deal in the Software without restriction,
9including without limitation the rights to use, copy, modify, merge, publish, distribute,
10sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is
11furnished to do so, subject to the following conditions:
12
13The above copyright notice and this permission notice shall be included in all copies or substantial
14portions of the Software.
15
16THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT
17LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
18IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
19WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
20SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
21
22|#
23
24
25;; These are useful for manipulating various types of NSObjects using lisp
26
27(defpackage :lisp-controller
28  (:nicknames :lc)
29  (:use :ccl :common-lisp))
30
31(defgeneric lc::modified-bound-value (controller edited-obj key old-val new-val))
32
33(defpackage :interface-utilities
34  (:nicknames :iu)
35  (:export 
36   archive-slots
37   bound-slot-modified
38   bound-slot-will-be-modified
39   class-name-string
40   clear-instance-hash
41   clear-objc-hash
42   did-change-value-for-key
43   do-objc-array
44   do-sequence
45   find-ns-classes
46   lisp-to-ns-array
47   lisp-to-ns-dict
48   lisp-to-ns-object
49   lisp-to-ns-misc
50   lisp-to-ns-sym
51   lisp-ptr-wrapper
52   lpw-lisp-ptr
53   lpw-depth
54   lpw-parent
55   make-ptr-wrapper
56   ns-to-lisp-array
57   ns-to-lisp-assoc
58   ns-to-lisp-classname
59   ns-to-lisp-hash-table
60   ns-to-lisp-list
61   ns-to-lisp-object
62   objc-displayable
63   objc-to-lisp-sym
64   obj-if-not-null
65   ns-misc
66   ns-sym
67   objc-to-std-instance
68   print-ns-object
69   recursive-map
70   std-instance-to-objc
71   while-converting
72   while-unconverting
73   will-change-value-for-key
74   wrapper-for))
75
76(eval-when (:compile-toplevel :load-toplevel :execute)
77  (require :ns-string-utils)
78  (require :ns-binding-utils)
79  (require :kvo-slot)
80  (require :nslog-utils)
81  (require :date)
82  (require :alert)
83  (require :decimal)
84  (require :assoc-array))
85
86(in-package :iu)
87
88(defun print-ns-object (ns-obj)
89  ;; default print methods for objects truncate strings at 1024 characters for some reason
90  ;; this function doesn't
91  (if (ccl::objc-object-p ns-obj)
92    (format t "~a" (ns-to-lisp-string (#/description ns-obj)))
93    (format t "~s" ns-obj)))
94
95(defun obj-if-not-null (ns-obj)
96  (if (eql ns-obj (%null-ptr))
97    nil
98    ns-obj))
99
100(defun unreadable-object-string-p (str)
101  ;; returns t if str contains a "#<" substring
102  (search "#<" str))
103
104(defun string-to-interned-symbol (str)
105  ;; str can be in form a, a:b, or a::b
106  (let* ((c1-pos (or (position #\: str) 0))
107         (c2-pos (or (position #\: str :from-end t) -1))
108         (pkg-str (string-upcase (subseq str 0 c1-pos)))
109         (name-str (string-upcase (subseq str (1+ c2-pos)))))
110    (if (string= pkg-str "")
111      (unless (string= name-str "")
112        (intern name-str))
113      (when (find-package pkg-str)
114        (intern name-str pkg-str)))))
115
116(defun recursive-map (func obj)
117  ;; apply func to obj and then to the results
118  ;; returned from that application recursively
119  ;; func can return either a list of objects or a single object
120  (let ((res (funcall func obj)))
121    (setf res (if (listp res) (copy-list res) (list res)))
122    (nconc res (mapcan #'(lambda (sub-obj)
123                           (recursive-map func sub-obj))
124                       res))))
125
126(defun class-name-string (class)
127  ;; we want a fully-qualified string (including package designation) for the class
128  ;; so symbol-name won't cut it.
129  (format nil "~s" (class-name class)))
130
131(defun ns-to-lisp-classname (classname-str &optional (previous-str ""))
132  ;; unlike ccl::objc-to-lisp-classname which does a syntactic translation
133  ;; and therefore fails to provide a package-qualified classname, this
134  ;; function finds the actual class and returns its name.
135  (unless (non-empty-string classname-str)
136    (return-from ns-to-lisp-classname ""))
137  (let ((cls (#_NSClassFromString (iu::lisp-to-temp-nsstring classname-str))))
138    (if (eql cls (%null-ptr))
139      ;; There isn't a known class with this name.
140      ;; If the lexical conversion of classname-str is identical to the part
141      ;; of the non-package portion of the previous string then just use the
142      ;; previous string.
143      (let* ((lisp-name (ccl::objc-to-lisp-classname classname-str))
144             (col-pos (position #\: previous-str :test #'char= :from-end t))
145             (prev-base (if col-pos
146                          (subseq previous-str (1+ col-pos))
147                          previous-str)))
148        (if (string= lisp-name prev-base)
149          previous-str
150          lisp-name))
151      (class-name-string cls))))
152
153(defun find-ns-classes (&key (if-pkg nil) (if-not-pkg nil))
154  ;; finds all subclasses of ns:ns-object which are explicitly in the non-null if-pkg
155  ;; or finds all that are explicitly not in the non-null if-not-pkg
156  ;; either keyword argument may contain a single package or package-name or a list
157  ;; of packages or package names
158  (let ((if-pkgs (mapcar #'find-package 
159                         (and if-pkg (if (consp if-pkg) if-pkg (list if-pkg)))))
160        (if-not-pkgs (mapcar #'find-package 
161                             (and if-not-pkg (if (consp if-not-pkg) if-not-pkg (list if-not-pkg)))))
162        (ns-classes (mapcar #'class-name (recursive-map #'class-direct-subclasses ns:ns-object))))
163    (when if-pkgs
164      (setf ns-classes (delete-if-not #'(lambda (class-name)
165                                          (member (find-package (symbol-package class-name)) if-pkgs))
166                                      ns-classes)))
167    (when if-not-pkgs
168      (setf ns-classes (delete-if #'(lambda (class-name)
169                                      (member (find-package (symbol-package class-name)) if-not-pkgs))
170                                  ns-classes)))
171    ns-classes))
172
173(defun ns-to-lisp-object (ns-obj &key (lisp-class nil) (ns-format nil))
174  ;; convert an arbitrary NSObject object to an appropriate lisp object.
175  ;; Often done so that it can replace the old-lisp-obj when edited
176  ;; An empty string @"" returns nil if old-lisp-obj is not a string
177  (cond ((ccl::subclassp lisp-class ns::ns-object)
178         ;; the target lisp class is some type of NSObject so just return the new value
179         ns-obj)
180        ((eql ns-obj (%null-ptr))
181         (if (ccl::subclassp lisp-class (find-class 'string))
182           ""
183           nil))
184        ((typep ns-obj 'lisp-ptr-wrapper)
185         ;; just strip the wrapper and return the original object
186         (lpw-lisp-ptr ns-obj))
187        ((typep ns-obj 'ns-sym)
188         (sym ns-obj))
189        ((typep ns-obj 'ns-misc)
190         (obj ns-obj))
191        ((typep ns-obj 'ns:ns-decimal-number)
192         (cond ((ccl::subclassp lisp-class (find-class 'double-float))
193                ;; convert the decimal to a double
194                (#/doubleValue ns-obj))
195               ((ccl::subclassp lisp-class (find-class 'float))
196                ;; convert the decimal to a float
197                (#/floatValue ns-obj))
198               (t
199                ;; otherwise convert it to an appropriate lisp integer with assumed
200                ;; decimals (see ip;Utilities;decimal.lisp)
201                (if (and (listp ns-format) (eq (first ns-format) :decimal))
202                  (lisp-from-ns-decimal ns-obj :decimals (second ns-format))
203                  (lisp-from-ns-decimal ns-obj)))))
204        ((typep ns-obj 'ns:ns-number)
205         (cond ((and (listp ns-format) (eq (first ns-format) :decimal))
206                (round (* (expt 10 (second ns-format)) (#/floatValue ns-obj))))
207               ((eq lisp-class (find-class 'symbol))
208                ;; how can a number be of class 'symbol? Simple, it is nil if number
209                ;; is 0 or t otherwise
210                (not (= (#/intValue ns-obj) 0)))
211               ((ccl::subclassp lisp-class (find-class 'double-float))
212                ;; convert the number to a double
213                (#/doubleValue ns-obj))
214               ((ccl::subclassp lisp-class (find-class 'float))
215                ;; convert the number to a float
216                (#/floatValue ns-obj))
217               ((ccl::subclassp lisp-class (find-class 'integer))
218                ;; convert the number to an integer
219                (#/longLongValue ns-obj))
220               ((ccl::subclassp lisp-class (find-class 'ratio))
221                ;; convert the number to an integer
222                (#/floatValue ns-obj))
223               ((eql ns-obj (#/numberWithBool: ns:ns-number #$YES))
224                ;; the number is the constant for #$YES, convert to t
225                ;; This does NOT convert all numbers with the value 1 to t
226                t)
227               ((eql ns-obj (#/numberWithBool: ns:ns-number #$NO))
228                ;; the number is the constant for #$NO, convert to nil
229                ;; This does NOT convert all numbers with the value 0 to nil
230                nil)
231               (t
232                ;; no specific target, so just read from the string representation
233                (read-from-string (ns-to-lisp-string
234                                   (#/descriptionWithLocale: ns-obj (%null-ptr)))
235                                  nil nil))))
236        ((typep ns-obj 'ns:ns-date)
237         (ns-to-lisp-date ns-obj))
238        ((typep ns-obj 'lisp-object-reference)
239         (objc-to-std-instance ns-obj))
240        ((typep ns-obj 'ns:ns-dictionary)
241         (cond ((ccl::subclassp lisp-class (find-class 'list))
242                (ns-to-lisp-assoc ns-obj))
243               (t
244                (ns-to-lisp-hash-table ns-obj))))
245        ((typep ns-obj 'ns:ns-array)
246         (if (ccl::subclassp lisp-class (find-class 'list))
247           (ns-to-lisp-list ns-obj)
248           (ns-to-lisp-array ns-obj)))
249        ((typep ns-obj 'ns:ns-string)
250         (let ((lisp-str (ns-to-lisp-string ns-obj)))
251           (cond ((ccl::subclassp lisp-class (find-class 'string))
252                  lisp-str)
253                 ((ccl::subclassp lisp-class (find-class 'symbol))
254                  (string-to-interned-symbol lisp-str))
255                 ((ccl::subclassp lisp-class (find-class 'number))
256                  (let ((num (read-from-string lisp-str :nil 0)))
257                    (if (numberp num)
258                      num
259                      0)))
260                 (t
261                  lisp-str))))
262        ((typep ns-obj 'ns:ns-null)
263         nil)
264        (t
265         ;; can't convert so just return ns-obj
266         ns-obj)))
267
268(defun lisp-to-ns-object (lisp-obj &optional (ns-format nil))
269  ;; convert an arbitrary lisp object to an appropriate NSObject so
270  ;; that it can be displayed someplace
271  (cond ((ccl::objc-object-p lisp-obj)
272         ;; it's already an NSObject so just return it
273         lisp-obj)
274        ((eq ns-format :date)
275         ;; assume lisp-obj is an integer representing a lisp date
276         (lisp-to-ns-date lisp-obj))
277        ((and (consp ns-format) (eq (first ns-format) :decimal))
278         (cond ((typep lisp-obj 'fixnum)
279                (lisp-to-ns-decimal lisp-obj :decimals (second ns-format)))
280               ((typep lisp-obj 'number)
281                (lisp-to-ns-decimal (round (* (expt 10 (second ns-format)) lisp-obj))
282                                    :decimals (second ns-format)))
283               (t
284                (lisp-to-ns-decimal 0 :decimals (second ns-format)))))
285        ((typep lisp-obj '(signed-byte 16))
286         (#/numberWithShort: ns:ns-number lisp-obj))
287        ((typep lisp-obj '(signed-byte 32))
288         (#/numberWithLong: ns:ns-number lisp-obj))
289        ((typep lisp-obj '(signed-byte 64))
290         (#/numberWithLongLong: ns:ns-number lisp-obj))
291        ((typep lisp-obj 'double-float)
292         (#/numberWithDouble: ns:ns-number lisp-obj))
293        ((floatp lisp-obj)
294         (#/numberWithFloat: ns:ns-number lisp-obj))
295        ((ratiop lisp-obj)
296         (#/numberWithFloat: ns:ns-number (float lisp-obj)))
297        ((floatp lisp-obj)
298         ;; some other type of floating number
299         (#/numberWithFloat: ns:ns-number (float lisp-obj)))
300        ((integerp lisp-obj)
301         ;; some other type of integer number
302         (#/numberWithLongLong: ns:ns-number (coerce lisp-obj '(signed-byte 64))))
303        ((complexp lisp-obj)
304         ;; no Objective-C counterpart so just return the realpart of the complex
305         (#/numberWithFloat: ns:ns-number (float (realpart lisp-obj))))
306        ((null lisp-obj)
307         (#/numberWithBool: ns:ns-number #$NO))
308        ((eq lisp-obj t)
309         (#/numberWithBool: ns:ns-number #$YES))
310        ((symbolp lisp-obj)
311         (lisp-to-ns-sym lisp-obj))
312        ((stringp lisp-obj)
313         (lisp-to-temp-nsstring lisp-obj))
314        ((hash-table-p lisp-obj)
315         (lisp-to-ns-dict lisp-obj))
316        ((or (vectorp lisp-obj) (consp lisp-obj))
317         (lisp-to-ns-array lisp-obj))
318        ((or (typep lisp-obj 'standard-object)
319             (typep lisp-obj 'structure-object))
320         (std-instance-to-objc lisp-obj))
321        (t
322         (lisp-to-ns-misc lisp-obj))))
323
324;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
325;; Methods dealing with standard-object instances
326
327(defvar *converting* nil)
328(defvar *unconverting* nil)
329
330;; The *ns-object-hash* keeps track of instances that have been converted to objc objects and
331;; only converts an instance one time.
332(defvar *ns-object-hash* nil)
333
334;; Similarly, *lisp-object-assoc* keeps track of objc objects that have been turned into lisp objects
335;; and always returns the same lisp obj for the multiple invocations of objc-to-std-instance
336;; that pass in the same objc object and are looking for the same lisp target class.
337(defvar *lisp-object-assoc* nil)
338
339(defun vals ()
340  (declare (special *converting* *ns-object-hash*))
341  (values *converting* *ns-object-hash*))
342
343(defmacro while-converting (&rest body)
344  `(let ((*converting* t)
345         (*ns-object-hash* (make-hash-table)))
346     (prog1 (progn ,@body)
347       (maphash #'(lambda (key val)
348                    (declare (ignore key))
349                    (#/release val))
350                *ns-object-hash*))))
351
352(defmacro while-unconverting (&rest body)
353  `(let ((*unconverting* t)
354         (*lisp-object-assoc* (make-instance 'assoc-array :rank 2 :tests (list #'eql #'eq))))
355     (prog1 (progn ,@body)
356       ;; release all the objects we retained in note-unconverted-object
357       (map-assoc-array #'(lambda (obj x)
358                            (declare (ignore x))
359                            (#/release obj))
360                        *lisp-object-assoc*))))
361
362(defun note-converted-object (lisp-obj ns-obj)
363  (declare (special *converting* *ns-object-hash*))
364  (when *converting*
365    (#/retain ns-obj)
366    (setf (gethash lisp-obj *ns-object-hash*) ns-obj)))
367
368(defun note-unconverted-object (ns-obj lisp-target-class lisp-obj)
369  (declare (special *unconverting* *lisp-object-assoc*))
370  (when *unconverting*
371    (#/retain ns-obj)
372    (setf (assoc-aref *lisp-object-assoc* ns-obj lisp-target-class) lisp-obj)))
373
374(defun converted-object (lisp-obj)
375  (declare (special *converting* *ns-object-hash*))
376  (and *converting*
377       (gethash lisp-obj *ns-object-hash* nil)))
378
379(defun unconverted-object (lisp-obj lisp-target-class)
380  (declare (special *unconverting* *lisp-object-assoc*))
381  (and *unconverting*
382       (assoc-aref *lisp-object-assoc* lisp-obj lisp-target-class)))
383
384;; A class that encapsulates references to other instances so that we can have circular
385;; references.
386
387(defclass lisp-object-reference (ns:ns-object)
388  ((obj-dict :accessor obj-dict :initarg :obj-dict))
389  (:default-initargs :obj-dict nil)
390  (:metaclass ns:+ns-object))
391
392(defmethod initialize-instance :after ((self lisp-object-reference) &key obj-dict &allow-other-keys)
393  (when (and obj-dict (ccl::objc-object-p obj-dict))
394    (#/retain obj-dict)))
395
396(objc:defmethod (#/dealloc :void)
397                ((self lisp-object-reference))
398  (with-slots (obj-dict) self
399    (when (and obj-dict (ccl::objc-object-p obj-dict))
400    (#/release obj-dict))))
401
402(objc:defmethod (#/initWithCoder: :id)
403                ((self lisp-object-reference) (decoder :id))
404  (setf (obj-dict self) (#/retain (#/decodeObjectForKey: decoder #@"obj-dict")))
405  self)
406
407(objc:defmethod (#/encodeWithCoder: :void)
408                ((self lisp-object-reference) (coder :id))
409  (#/encodeObject:forKey: coder
410                          (obj-dict self)
411                          #@"obj-dict"))
412
413(defun instance-to-ref (obj)
414  (or (converted-object obj)
415      (let* ((slots (archive-slots obj))
416             (obj-dict (make-instance ns:ns-mutable-dictionary
417                         :with-capacity (1+ (* 2 (list-length slots)))))
418             (obj-ref (make-instance 'lisp-object-reference :obj-dict obj-dict)))       
419        (note-converted-object obj obj-ref)
420        (#/setObject:forKey: obj-dict
421                             (lisp-to-ns-object (class-name (class-of obj)))
422                             #@"__instance-class__")
423        (dolist (slot slots)
424          (let ((slot-str (string slot))
425                (slot-val (slot-value obj slot)))
426            (#/setObject:forKey: obj-dict
427                                 (lisp-to-ns-object (class-name (class-of slot-val)))
428                                 (lisp-to-temp-nsstring (concatenate 'string 
429                                                                     slot-str
430                                                                     "__class__")))
431            (#/setObject:forKey: obj-dict
432                                 (lisp-to-ns-object slot-val)
433                                 (lisp-to-temp-nsstring slot-str))))
434        (#/autorelease obj-ref))))
435
436(defmethod std-instance-to-objc ((obj standard-object))
437  ;; Default method for converting an object instance to an Objective-C dictionary object.
438  ;; This is used to create objects that can be converted and restored by normal Objective-C
439  ;; methods such as encodeWithCoder: and initWithCoder:.
440  ;; Classes can override or specialize this in any way they want as long as some Objective-C
441  ;; instance is returned.
442  (instance-to-ref obj))
443
444(defmethod std-instance-to-objc ((obj structure-object))
445  ;; Default method for converting an structure instance to an Objective-C dictionary object.
446  ;; This is used to create objects that can be converted and restored by normal Objective-C
447  ;; methods such as encodeWithCoder: and initWithCoder:.
448  ;; Classes can override or specialize this in any way they want as long as some Objective-C
449  ;; instance is returned.
450  (instance-to-ref obj))
451
452(defmethod objc-to-std-instance ((ref lisp-object-reference) &optional new-instance)
453  (or (unconverted-object ref nil)
454      (let* ((obj-dict (obj-dict ref))
455             (class (find-class (ns-to-lisp-object
456                                 (#/objectForKey: obj-dict #@"__instance-class__"))
457                                nil))
458             (inst (and class
459                        (if (ccl::subclassp (class-of new-instance) class)
460                          ;; if new-instance is specified and is of a compatible type,
461                          ;; then just set the values in its slots from the NSDictionary
462                          ;; object. Otherwise create a new instance.
463                          new-instance
464                          (make-instance class)))))
465        (unless class
466          (ns-log (format nil
467                          "Bad dictionary found in objc-to-std-instance: ~s" obj-dict))
468          (alert :text 
469           "In objc-to-std-instance, no instance-class found in NSDictionary, returned object will be nil. See console log for more information"))
470        (when inst
471          (note-unconverted-object ref nil inst)
472          (dolist (slot (archive-slots inst) inst)
473            (let* ((slot-str (string slot))
474                   (slot-class-key-str (lisp-to-temp-nsstring (concatenate 'string
475                                                                           slot-str
476                                                                           "__class__")))
477                   (slot-class-str (ns-to-lisp-object (#/objectForKey: obj-dict 
478                                                                       slot-class-key-str)))
479                   (slot-class (find-class slot-class-str nil))
480                   (objc-slot-val (#/objectForKey: obj-dict (lisp-to-temp-nsstring slot-str)))
481                   (slot-val (ns-to-lisp-object 
482                              objc-slot-val
483                              :lisp-class slot-class)))
484              (when (ccl::objc-object-p slot-val)
485                (#/retain slot-val))
486              (cond ((eq slot-val :none)
487                     (ns-log (format nil
488                                     "Saved value for ~s slot cannot be converted to Lisp. Value: ~s"
489                                     slot
490                                     objc-slot-val)))
491                    ((not (eql objc-slot-val (%null-ptr)))
492                     ;; We found an archived value for the slot
493                     (setf (slot-value inst slot) slot-val))
494                    (t
495                     ;; There is now a slot in the object that wasn't archived in the saved version of
496                     ;; this instance. We just let the default initial value take care of it and do
497                     ;; nothing here.
498                     nil))))))))
499
500(defun instance-hash-table-p (ns-dict)
501  ;; ns-dict must be an NSDictionary object
502  ;; check to see if it is an encoded standard-instance
503  (not (eql (%null-ptr) (#/objectForKey: ns-dict #@"__instance-class__"))))
504
505(defun arch-slots (obj)
506  ;; by default return a list of all non-foreign slots
507  ;; object classes that do not want to archive all such slots may
508  ;; override this function for their class
509  (mapcar #'ccl::slot-definition-name
510          (remove-if #'(lambda (eslot)
511                         (subtypep (type-of eslot) 'ccl::foreign-effective-slot-definition))
512                     (class-slots (class-of obj)))))
513
514(defmethod archive-slots ((obj standard-object))
515  ;; by default return a list of all non-foreign slots
516  ;; object classes that do not want to archive all such slots may
517  ;; override this function for their class
518  (arch-slots obj))
519
520(defmethod archive-slots ((obj structure-object))
521  ;; by default return a list of all non-foreign slots
522  ;; object classes that do not want to archive all such slots may
523  ;; override this function for their class
524  (arch-slots obj))
525
526;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
527;; Methods dealing with NSArray objects
528
529(defmacro do-objc-array ((arr-elt arr &optional (return t)) &rest body)
530  (let ((arr-indx (gensym)))
531    `(dotimes (,arr-indx (#/count ,arr) ,return)
532       (let ((,arr-elt (#/objectAtIndex: ,arr ,arr-indx)))
533         ,@body))))
534
535(defmethod ns-to-lisp-array ((ns-arr ns:ns-array) &key (element-class nil))
536  (let ((new-arr (make-array (list 0) :adjustable t :fill-pointer t)))
537    (do-objc-array (elt ns-arr new-arr)
538       (vector-push-extend (if (ccl::subclassp element-class ns:ns-object)
539                             elt
540                             (ns-to-lisp-object elt
541                                                :lisp-class element-class))
542                           new-arr))))
543
544(defmethod ns-to-lisp-list ((ns-arr ns:ns-array) &key (element-class nil))
545  (let ((new-list nil))
546    (do-objc-array (elt ns-arr (nreverse new-list))
547       (setf new-list 
548              (cons (if (ccl::subclassp element-class ns:ns-object)
549                      elt
550                      (ns-to-lisp-object elt
551                                         :lisp-class element-class))
552                    new-list)))))
553
554(defmethod lisp-to-ns-array ((lst list))
555  (let ((new-arr (#/arrayWithCapacity: ns:ns-mutable-array (list-length lst)))
556        (count -1))
557    (dolist (item lst new-arr)
558      (#/insertObject:atIndex: new-arr
559                               (lisp-to-ns-object item)
560                               (incf count)))))
561
562(defmethod lisp-to-ns-array ((arr array))
563  (let* ((max-count (if (array-has-fill-pointer-p arr)
564                     (fill-pointer arr)
565                     (length arr)))
566         (new-arr (#/arrayWithCapacity: ns:ns-mutable-array max-count)))
567    (do* ((count 0 (1+ count)))
568         ((>= count max-count) new-arr)
569      (#/insertObject:atIndex: new-arr
570                               (lisp-to-ns-object (aref arr count))
571                               count))))
572
573;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
574;; Methods dealing with NSDictionary objects
575
576(defmethod ns-to-lisp-hash-table ((dict ns:ns-dictionary) &key (element-class nil))
577  (let ((ht (make-hash-table :test #'equal))
578        (dict-keys (ns-to-lisp-list (#/allKeys dict)
579                                    :element-class ns:ns-object)))
580    (dolist (key dict-keys ht)
581      (setf (gethash (ns-to-lisp-object key) ht)
582            (if (ccl::subclassp element-class ns:ns-object)
583              (#/objectForKey: dict key)
584              (ns-to-lisp-object (#/objectForKey: dict key)
585                                 :lisp-class element-class))))))
586
587(defmethod ns-to-lisp-assoc ((dict ns:ns-dictionary) &key (element-class nil))
588  (let ((assoc-lst nil)
589        (dict-keys (ns-to-lisp-list (#/allKeys dict)
590                                    :element-class ns:ns-object)))
591    (dolist (key dict-keys assoc-lst)
592      (setf assoc-lst
593            (acons (ns-to-lisp-object key)
594                   (if (ccl::subclassp element-class ns:ns-object)
595                     (#/objectForKey: dict key)
596                     (ns-to-lisp-object (#/objectForKey: dict key)
597                                        :lisp-class element-class))
598                   assoc-lst)))))
599
600(defmethod lisp-to-ns-dict ((alist list))
601  ;; alist must be in the form of an association list
602  (let* ((count (list-length alist))
603         (new-dict (#/dictionaryWithCapacity: ns:ns-mutable-dictionary count)))
604    (dolist (pair alist new-dict)
605      (#/setObject:forKey: new-dict 
606                           (lisp-to-ns-object (cdr pair))
607                           (lisp-to-ns-object (car pair))))))
608
609(defmethod lisp-to-ns-dict ((ht hash-table))
610  (let* ((count (hash-table-count ht))
611         (new-dict (#/dictionaryWithCapacity: ns:ns-mutable-dictionary count)))
612    (maphash #'(lambda (key val)
613                 (#/setObject:forKey: new-dict 
614                                      (lisp-to-ns-object val)
615                                      (lisp-to-ns-object key)))
616             ht)
617    new-dict))
618
619(deftype objc-displayable () 
620  '(or string
621       (and atom 
622            (not sequence)
623            (not hash-table)
624            (not package) 
625            (not pathname)
626            (not random-state)
627            (not readtable)
628            (not array)
629            (not stream)
630            (not class)
631            (not structure-object)
632            (not standard-object)
633            (not macptr))))
634
635;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
636;; lisp-ptr-wrapper
637;;
638;; This is a class that encapsulates a pointer to a lisp object so we can pass this
639;; off to an Objective-C view and know what it points to when we get it back later.
640;; Added the ability to handle bindings.
641
642(defclass lisp-ptr-wrapper (ns:ns-object)
643  ((lpw-lisp-ptr :accessor lpw-lisp-ptr)
644   (lpw-controller :accessor lpw-controller)
645   (lpw-depth :accessor lpw-depth)
646   (lpw-parent :accessor lpw-parent))
647  (:metaclass ns:+ns-object))
648
649(objc:defmethod (#/copyWithZone: :id)
650                ((self lisp-ptr-wrapper) (zone (* #>NSZone)))
651  ;; (ns-log (format nil "Copying wrapper for ~s" (lpw-lisp-ptr self)))
652  self)
653
654(let ((kvc-observed (make-instance 'assoc-array :rank 2 :tests (list #'eql #'equal)))
655      (obj-wrappers (make-instance 'assoc-array :rank 2)))
656  ;; this assoc-array keeps track of paths that are being observed and the
657  ;; corresponding lisp-ptr-wrapper object that is ostensibly being observed.
658
659  (defun make-ptr-wrapper (ptr &key (depth 1) (parent nil) (controller nil))
660    ;; (ns-log (format nil "Making wrapper for ~s" ptr))
661    (let ((lpw (make-instance 'lisp-ptr-wrapper)))
662      (setf (lpw-lisp-ptr lpw) ptr)
663      (setf (lpw-depth lpw) depth)
664      (setf (lpw-parent lpw) parent)
665      (setf (lpw-controller lpw) controller)
666      (setf (assoc-aref obj-wrappers controller ptr) lpw)
667      lpw))
668
669  (defmethod wrapper-for (controller lisp-obj &key (depth 0) (parent nil))
670    (or (assoc-aref obj-wrappers controller lisp-obj)
671        (setf (assoc-aref obj-wrappers controller lisp-obj)
672              (make-ptr-wrapper lisp-obj 
673                                :depth depth
674                                :parent parent
675                                :controller controller))))
676
677  (defmethod note-kvc-observed ((self lisp-ptr-wrapper) lisp-obj path)
678    ;; (ns-log (format nil "Observing ~s for ~s" path-sym lisp-obj))
679    (pushnew self (assoc-aref kvc-observed lisp-obj path)))
680
681  (defmethod will-change-value-for-key (owner key)
682    ;; called from a lisp object to tell us that a value will be changed.
683    ;; We find the lisp-ptr-wrapper instances that have been used to access
684    ;; the owner via the specified key and call the appropriate
685    ;; method to lets KVC know what is going on.
686    ;; (ns-log (format nil "Will change ~s for ~s" key owner))
687    (let ((owner-lpws (assoc-aref kvc-observed owner key))
688          (objc-key (lisp-to-temp-nsstring (if (stringp key)
689                                             key
690                                             (lisp-to-objc-keypathname key)))))
691      (dolist (lpw owner-lpws)
692        ;; (ns-log (format nil "#/willChangeValueForKey: ~s ~s" lpw objc-key))
693        (#/willChangeValueForKey: lpw objc-key))))
694
695  (defmethod did-change-value-for-key (owner key)
696    ;; called from a lisp object to tell us that a value changed.
697    ;; We find the lisp-ptr-wrapper instances that have been used to access
698    ;; the owner via the specified key and call the appropriate
699    ;; method to lets KVC know what is going on.
700    ;; (ns-log (format nil "Did change ~s for ~s" key owner))
701    (let ((owner-lpws (assoc-aref kvc-observed owner key))
702          (objc-key (lisp-to-temp-nsstring (if (stringp key)
703                                             key
704                                             (lisp-to-objc-keypathname key)))))
705      (dolist (lpw owner-lpws)
706        ;; (ns-log (format nil "#/didChangeValueForKey: ~s ~s" lpw objc-key))
707        (#/didChangeValueForKey: lpw objc-key))))
708
709  (defun kvc-observed ()
710    kvc-observed)
711)
712;; end of definitions with access to kvc-observed assoc-array
713
714(defun reader-selector (str)
715  (ccl::%get-selector (ccl::load-objc-selector  str)))
716
717(defun writer-selector (str)
718  (ccl::%get-selector (ccl::load-objc-selector (concatenate 'string "set" (string-capitalize str :end 1)))))
719
720(defmethod bound-slot-will-be-modified ((self standard-object) slot-name)
721  (declare (ignore slot-name))
722  ;; do nothing by default
723  )
724
725(defmethod bound-slot-modified ((self standard-object) slot-name)
726  (declare (ignore slot-name))
727  ;; do nothing by default
728  )
729
730(defmethod real-observer (nskvo)
731  ;; nskvo will be an instance of NSKeyValueObservance which isn't public as far as I can tell.
732  ;; All we want is a pointer to the original observer extracted from that object, but without
733  ;; a public API that is a little tricky. But we are trickier. We use the #/description of that
734  ;; object which provides a substring of the form "Observer: 0x<whatever>" which points to
735  ;; possibly another non-public object of type NSSelectionBinder. We extract the address and
736  ;; create a pointer to the NSSelectionbinder. We now use its description to extract its
737  ;; "object" slot address, which hopefully points to the original view object that we bound
738  ;; to our lisp object. We use that to create a macptr and return it.
739  (let* ((desc (ns-to-lisp-string (#/description nskvo)))
740         (obs-start (search "Observer: " desc))
741         (hex-start (and obs-start (position #\x desc :start (+ obs-start 9))))
742         (hex-end (and hex-start (position #\, desc :start hex-start)))
743         (hex-val (and hex-end (read-from-string (concatenate 'string "#" (subseq desc hex-start hex-end)) nil 0)))
744         (nssb-ptr (and hex-val (ccl::%int-to-ptr hex-val)))
745         (nssb-desc (and nssb-ptr (ns-to-lisp-string (#/description nssb-ptr))))
746         (obj-start (search "object:" nssb-desc))
747         (obj-class-end (and obj-start (position #\: nssb-desc :start (+ obj-start 8))))
748         (obj-hex-start (and obj-class-end (position #\x nssb-desc :start obj-class-end)))
749         (obj-hex-end (and obj-hex-start (position #\> nssb-desc :start obj-hex-start)))
750         (obj-hex-val (and obj-hex-end (read-from-string (concatenate 'string "#" (subseq nssb-desc obj-hex-start obj-hex-end)) nil 0))))
751    (when obj-hex-val
752      (ccl::%int-to-ptr obj-hex-val))))
753
754(let ((format-assoc (make-instance 'assoc-array :rank 2 :tests (list #'eql #'equal))))
755  ;; used to hold needed Objective-C format information for slots that are observed by
756  ;; Objective-C objects that have associated formatter objects from which we can take hints.
757
758  (defun set-format-assoc (path-obj path format)
759    (setf (assoc-aref format-assoc path-obj path) format))
760
761  (defun format-for (path-obj path)
762    (assoc-aref format-assoc path-obj path))
763
764)
765
766(objc:defmethod (#/addObserver:forKeyPath:options:context: :void)
767                ((self lisp-ptr-wrapper) (obs :id) (key-path :id) (options #>NSUInteger) (context :address))
768  (let ((observer (real-observer obs)))
769    ;; (ns-log (format nil "~s observed by ~s" (lpw-lisp-ptr self) observer))
770    (when (subtypep (type-of observer) 'ns:ns-control)
771      (let* ((cell (#/cell observer))
772             (formatter (#/formatter cell))
773             (ns-format nil))
774        (cond ((or (typep cell 'ns:ns-date-picker-cell)
775                   (typep formatter 'ns:ns-date-formatter))
776               (setf ns-format :date))
777              ((typep formatter 'ns:ns-number-formatter)
778               (cond ((#/generatesDecimalNumbers formatter)
779                      (let ((dec-digits (#/maximumFractionDigits formatter)))
780                        (setf ns-format (list :decimal dec-digits))))
781                     (t
782                      (setf ns-format :number)))))
783        (when ns-format
784          ;; (ns-log (format nil "Observer data format: ~s" ns-format))
785          (set-format-assoc self (ns-to-lisp-string key-path) ns-format)
786          ;; We use the ns-format as a hint about how the lisp field is
787          ;; formatted and convert accordingly when that value is retrieved.
788          ;; Any controls that previously observed this field might have
789          ;; received misformatted data, so indicate that the data changed
790          ;; so they will go get it again. This primarily occurs when a new
791          ;; window is open and controls are first observing the field.
792          (#/willChangeValueForKey: self key-path)
793          (#/didChangeValueForKey: self key-path)))))
794  (call-next-method obs key-path options context))
795
796(objc:defmethod (#/valueForKey: :id)
797                ((self lisp-ptr-wrapper) (path :id))
798  ;; Treat path as a lisp path as long as it works.
799  ;; If it is not valid and the next target is an Objective-C object
800  ;; then treat the path as a normal Objective-C Key and return the results
801  ;; of calling #/valueForKey: on the target using path as the key.
802  (let* ((lisp-str (ns-to-lisp-string path))
803         (lisp-path (objc-to-lisp-keypathname lisp-str))
804         (ptr-obj (lpw-lisp-ptr self))
805         ;; to set next-obj we try 3 ways:
806         ;; 1. If the path is a valid lisp function name use it to access the slot
807         ;; 2. If the object is an Objective-C object try calling its #/valueForKey method
808         ;; 3. Look for any KVO slots defined for the object with path specified as the KVO
809         ;;    accessor and use the lisp function value-for-kvo-key to access that slot
810         (next-obj (cond ((and (typep lisp-path 'function-name)
811                               (fboundp lisp-path))
812                          (funcall lisp-path ptr-obj))
813                         ((and (typep ptr-obj 'objc:objc-object)
814                               (#/respondsToSelector: ptr-obj (reader-selector lisp-str)))
815                          (#/valueForKey: ptr-obj path))
816                         (t
817                          (ccl::value-for-kvo-key ptr-obj lisp-str)))))
818    ;; First track that the path is being observed by somebody
819    (note-kvc-observed self (lpw-lisp-ptr self) lisp-path)
820    (note-kvc-observed self (lpw-lisp-ptr self) lisp-str)
821    ;; (ns-log (format nil "(~s ~s) returned ~s" lisp-path (lpw-lisp-ptr self) next-obj))
822    (cond ((eql next-obj (%null-ptr))
823           next-obj)
824          ((null next-obj)
825           (%null-ptr))
826          ((and (typep next-obj 'ns:ns-object)
827                (not (typep next-obj 'ccl::kvo-object)))
828           ;; any kvo-objects will be encapsulated in a lisp-ptr-wrapper
829           ;; so that subsequent accesses through this method will try to
830           ;; use ccl::value-for-kvo-key
831           next-obj)
832          ((typep next-obj 'objc-displayable)
833           (lisp-to-ns-object next-obj (format-for self lisp-str)))
834          (t
835           (wrapper-for (lpw-controller self) next-obj :parent (lpw-lisp-ptr self))))))
836
837(objc:defmethod (#/setValue:forKey: :void)
838                ((self lisp-ptr-wrapper) (new-value :id) (path :id))
839  (let* ((lisp-str (ns-to-lisp-string path))
840         (lisp-path (objc-to-lisp-keypathname lisp-str))
841         (ptr-obj (lpw-lisp-ptr self))
842         (prev-obj (cond ((and (typep lisp-path 'function-name)
843                               (fboundp lisp-path))
844                          (funcall lisp-path ptr-obj))
845                         ((and (typep ptr-obj 'objc:objc-object)
846                               (#/respondsToSelector: self (reader-selector lisp-str)))
847                          (#/valueForKey: ptr-obj path))
848                         (t
849                          (ccl::value-for-kvo-key ptr-obj lisp-str))))
850         (prev-class (class-of prev-obj))
851         (new-lisp-obj (ns-to-lisp-object new-value :lisp-class prev-class :ns-format (format-for self lisp-str)))
852         (setf-func (fboundp (list 'setf lisp-path)))
853         ;;`(setf (,lisp-path ,(lpw-lisp-ptr self)) ,new-lisp-obj))
854         (ctrl (lpw-controller self)))
855    ;; (ns-log (format nil "Prev Class: ~s" prev-class))
856    (cond (setf-func
857           (funcall setf-func new-lisp-obj ptr-obj))
858          ((and (typep ptr-obj 'objc:objc-object)
859                (typep new-lisp-obj 'objc:objc-object)
860                (#/respondsToSelector: self (writer-selector lisp-str)))
861           (#/setValue:forKey: ptr-obj new-lisp-obj path))
862          (t
863           (let* ((found-slot (ccl::kvo-slot-for ptr-obj lisp-str))
864                  (slot-name (and found-slot (ccl::slot-definition-name found-slot))))
865             (if found-slot
866               (progn
867                 (bound-slot-will-be-modified ptr-obj slot-name)
868                 (setf (ccl::value-for-kvo-key ptr-obj lisp-str) new-lisp-obj)
869                 (bound-slot-modified ptr-obj (ccl::slot-definition-name found-slot)))
870               ;; If the setf  failed, log the original condition
871               (error "No way to setValue: ~s forKey: ~s for lisp-ptr ~s"
872                      new-lisp-obj
873                      lisp-str
874                      ptr-obj)))))
875    (when ctrl
876      (lc::modified-bound-value ctrl
877                                (lpw-lisp-ptr self) 
878                                lisp-path
879                                prev-obj
880                                new-lisp-obj))
881    new-lisp-obj))
882;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
883;;; methods to support access to Lisp lists and arrays as if they were NSArrays
884
885(objc:defmethod (#/count #>NSUInteger)
886                ((self lisp-ptr-wrapper))
887  (let ((ptr-obj (lpw-lisp-ptr self)))
888    (typecase ptr-obj
889      (list (list-length ptr-obj))
890      (vector (length ptr-obj))
891      (t 0))))
892
893(objc:defmethod (#/objectAtIndex: :id)
894                ((self lisp-ptr-wrapper) (indx #>NSUInteger))
895  (let* ((ptr-obj (lpw-lisp-ptr self))
896         (next-obj (typecase ptr-obj
897                     (list (nth indx ptr-obj))
898                     (vector (elt ptr-obj indx))
899                     (t (%null-ptr)))))
900    (cond ((eql next-obj (%null-ptr))
901           next-obj)
902          ((null next-obj)
903           (%null-ptr))
904          ((and (typep next-obj 'ns:ns-object)
905                (not (typep next-obj 'ccl::kvo-object)))
906           ;; any kvo-objects will be encapsulated in a lisp-ptr-wrapper
907           ;; so that subsequent accesses through this method will try to
908           ;; use ccl::value-for-kvo-key
909           next-obj)
910          ((typep next-obj 'objc-displayable)
911           (lisp-to-ns-object next-obj))
912          (t
913           (wrapper-for (lpw-controller self) next-obj :parent (lpw-lisp-ptr self))))))
914
915;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
916;; Methods dealing with conversion of lisp symbols
917;;
918;; Initially I implemented this as a concrete subclass of NSString, but it turned out that
919;; my #/initWithCoder: and #/encodeWithCoder: functions were never called when one of these
920;; was converted. It just encoded them as NSMutableStrings. So there is more than one way to
921;; skin a cat ...
922
923(defclass ns-sym (ns:ns-object)
924  ((sym :accessor sym :initarg :sym)
925   (ns-str :accessor ns-str)
926   (sym-name :accessor sym-name)
927   (sym-package :accessor sym-package))
928  (:metaclass ns:+ns-object))
929
930(defmethod initialize-instance :after ((self ns-sym) &key sym &allow-other-keys)
931  (setf (sym-name self) (symbol-name sym))
932  (setf (sym-package self) (symbol-package sym))
933  (setf (ns-str self) (ccl::%make-nsstring (format nil
934                                                   "~a:~a"
935                                                   (package-name (sym-package self))
936                                                   (sym-name self)))))
937
938(defmethod print-object ((self ns-sym) strm)
939  (print-unreadable-object (self strm :type t :identity t)
940    (format strm "~s" (sym self))))
941
942(objc:defmethod (#/dealloc :void)
943                ((self ns-sym))
944  (#/release (ns-str self))
945  (call-next-method))
946
947;; This method suffices to make an ns-sym act like an NSString if the runtime is 10.6 or higher
948(objc:defmethod (#/forwardingTargetForSelector: :id)
949                ((self ns-sym) (sel #>SEL))
950  (ns-str self))
951
952;; Otherwise the following two methods are needed
953
954(objc:defmethod (#/methodSignatureForSelector: :id)
955                ((self ns-sym) (sel #>SEL))
956  (#/methodSignatureForSelector: (ns-str self) sel))
957
958(objc:defmethod (#/forwardInvocation: :void)
959                ((self ns-sym) (inv :id))
960  (#/invokeWithTarget: inv (ns-str self)))
961
962(objc:defmethod (#/initWithCoder: :id)
963                ((self ns-sym) (decoder :id))
964  (let* ((sym-name (#/decodeObjectForKey: decoder #@"symName"))
965         (sym-pkg (#/decodeObjectForKey: decoder #@"symPkg"))
966         (pkg-str (ns-to-lisp-string sym-pkg)))
967    (setf (sym-name self) (ns-to-lisp-string sym-name))
968    (setf (sym-package self) (or (find-package pkg-str)
969                                 (make-package pkg-str)))
970    (setf (sym self) (intern (sym-name self) (sym-package self)))
971    (setf (ns-str self) (ccl::%make-nsstring (format nil
972                                                     "~@[~a:~]~a"
973                                                     (package-name (sym-package self))
974                                                     (sym-name self))))
975    self))
976
977(objc:defmethod (#/encodeWithCoder: :void)
978                ((self ns-sym) (coder :id))
979  (#/encodeObject:forKey: coder
980                          (lisp-to-temp-nsstring (sym-name self))
981                          #@"symName")
982  (#/encodeObject:forKey: coder 
983                          (lisp-to-temp-nsstring (package-name (sym-package self)))
984                          #@"symPkg"))
985
986(defmethod lisp-to-ns-sym ((sym symbol))
987  (make-instance 'ns-sym :sym sym))
988
989;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
990;; Methods dealing with conversion of miscellaneous lisp values that hopefully can
991;; be printed to and read from strings
992
993(defclass ns-misc (ns:ns-object)
994  ((obj :accessor obj :initarg :obj)
995   (obj-str :accessor obj-str)
996   (ns-str :accessor ns-str))
997  (:metaclass ns:+ns-object))
998
999(defmethod initialize-instance :after ((self ns-misc) &key obj &allow-other-keys)
1000  (setf (obj-str self) (format nil "~s" obj))
1001  (setf (ns-str self) (ccl::%make-nsstring (obj-str self))))
1002
1003(defmethod print-object ((self ns-misc) strm)
1004  (print-unreadable-object (self strm :type t :identity t)
1005    (format strm "~s" (obj-str self))))
1006
1007(objc:defmethod (#/dealloc :void)
1008                ((self ns-misc))
1009  (#/release (ns-str self))
1010  (call-next-method))
1011
1012;; This method suffices to make an ns-misc act like an NSString if the runtime is 10.6 or higher
1013(objc:defmethod (#/forwardingTargetForSelector: :id)
1014                ((self ns-misc) (sel #>SEL))
1015  (ns-str self))
1016
1017;; Otherwise the following two methods are needed
1018
1019(objc:defmethod (#/methodSignatureForSelector: :id)
1020                ((self ns-sym) (sel #>SEL))
1021  (#/methodSignatureForSelector: (ns-str self) sel))
1022
1023(objc:defmethod (#/forwardInvocation: :void)
1024                ((self ns-sym) (inv :id))
1025  (#/invokeWithTarget: inv (ns-str self)))
1026
1027(objc:defmethod (#/initWithCoder: :id)
1028                ((self ns-misc) (decoder :id))
1029  (let ((obj-str (#/decodeObjectForKey: decoder #@"objString")))
1030    (setf (obj-str self) (ns-to-lisp-string obj-str))
1031    (setf (obj self) (if (unreadable-object-string-p (obj-str self))
1032                       nil
1033                       (read-from-string (obj-str self) nil nil)))
1034    (setf (ns-str self) (#/retain obj-str))
1035    self))
1036
1037(objc:defmethod (#/encodeWithCoder: :void)
1038                ((self ns-misc) (coder :id))
1039  (#/encodeObject:forKey: coder
1040                          (ns-str self)
1041                          #@"objString"))
1042
1043(defmethod lisp-to-ns-misc (obj)
1044  (make-instance 'ns-misc :obj obj))
1045
1046(provide :ns-object-utils)
Note: See TracBrowser for help on using the repository browser.