Changeset 6112


Ignore:
Timestamp:
Mar 30, 2007, 2:45:19 PM (12 years ago)
Author:
gb
Message:

Get objc:defmethod mostly working (struct-return stuff NYI.)

First draft of rewritten Cocoa demo which uses it and the new
dispatch function mechanism. (Still some code to write, and still
some issues - struct return - to work out. Likely bugs/typos to
fix, as well.)

%DECLARE-OBJC-METHOD should happen at load/execute time; we can
use other means to generate the signature for CALL-NEXT-METHOD.
(Would be better to define a load-form for signature info, and
reference the signature info as a constant, anyway.)

Location:
branches/objc-gf/ccl/examples
Files:
12 edited

Legend:

Unmodified
Added
Removed
  • branches/objc-gf/ccl/examples/bridge.lisp

    r6104 r6112  
    264264(define-typed-foreign-struct-class ns::ns-size (:<NSS>ize ns::ns-size-p ns::init-ns-size ns::make-ns-size)
    265265  (width ns::ns-size-width :<NSS>ize.width wrap-cg-float)
    266   (height ns::ns-size-height :<NSS>ize.width wrap-cg-float))
     266  (height ns::ns-size-height :<NSS>ize.height wrap-cg-float))
    267267
    268268
     
    322322    (error "ObjC message name ~s contains colons, but last character is not a colon" (copy-seq string))))
    323323     
    324  
     324
     325(setf (pkg.intern-hook (find-package "NS"))
     326      'get-objc-message-info)
     327
    325328(set-dispatch-macro-character #\# #\/
    326329                              (lambda (stream subchar numarg)
     
    340343                                      (signal-reader-error stream "Invalid token after #/."))
    341344                                    (check-objc-message-name token)
    342                                     (let* ((symbol (intern token "NS")))
    343                                       (get-objc-message-info (symbol-name symbol))
    344                                       symbol)))))
     345                                    (intern token "NS")))))
    345346
    346347
     
    759760      (lfun-bits gf (dpb (1+ (objc-message-info-req-args message-info))
    760761                         $lfbits-numreq
    761                          (lfun-bits gf)))
     762                         (logior (ash
     763                                  (if (getf (objc-message-info-flags message-info)
     764                                            :accepts-varargs)
     765                                    1
     766                                    0)
     767                                  $lfbits-rest-bit)
     768                                 (logandc2 (lfun-bits gf) (ash 1 $lfbits-aok-bit)))))
    762769      (flet ((signature-function-for-method (m)
    763770               (let* ((signature-info (objc-method-info-signature-info m)))
     
    823830                                             
    824831
     832(defun %call-next-objc-method (self class selector sig &rest args)
     833  (declare (dynamic-extent args))
     834  (rlet ((s :objc_super #+apple-objc :receiver #+gnu-objc :self self
     835            #+apple-objc-2.0 :super_class #-apple-objc-2.0 :class
     836            #+apple-objc-2.0 (#_class_getSuperclass class)
     837            #-apple-objc-2.0 (pref class :objc_class.super_class)))
     838    (let* ((siginfo (objc-method-signature-info sig))
     839           (function (or (objc-method-signature-info-super-function siginfo)
     840                         (setf (objc-method-signature-info-super-function siginfo)
     841                               (%compile-send-function-for-signature sig t)))))
     842      (with-ns-exceptions-as-errors
     843          (apply function s selector args)))))
     844
     845
     846(defun %call-next-objc-class-method (self class selector sig &rest args)
     847  (rlet ((s :objc_super #+apple-objc :receiver #+gnu-objc :self self
     848            #+apple-objc-2.0 :super_class #-apple-objc-2.0 :class
     849            #+apple-objc-2.0 (#_class_getSuperclass (pref class :objc_class.isa))
     850            #-apple-objc-2.0 (pref (pref class #+apple-objc :objc_class.isa #+gnu-objc :objc_class.class_pointer) :objc_class.super_class)))
     851    (let* ((siginfo (objc-method-signature-info sig))
     852           (function (or (objc-method-signature-info-super-function siginfo)
     853                         (setf (objc-method-signature-info-super-function siginfo)
     854                               (%compile-send-function-for-signature sig t)))))
     855      (with-ns-exceptions-as-errors
     856          (apply function s selector args)))))
    825857
    826858(defun postprocess-objc-message-info (message-info)
     
    949981;;; with the message-declaration (OBJC-MESSAGE-INFO structure) M,
    950982;;; return the one that seems to be applicable for the object O.
    951 ;;; (If there's no ambiguity among the declare methods, any method
     983;;; (If there's no ambiguity among the declared methods, any method
    952984;;; will do; this just tells runtime %SEND functions how to compose
    953985;;; an %FF-CALL).
     
    964996       (error "Can't determine ObjC method type signature for message ~s, object ~s" (objc-message-info-message-name m) o)))))
    965997
     998(defun resolve-existing-objc-method-info (message-info class-name class-p result-type args)
     999  (let* ((method-info (dolist (m (objc-message-info-methods message-info))
     1000                        (when (and (eq (getf (objc-method-info-flags m) :class-p)
     1001                                       class-p)
     1002                                   (equal (objc-method-info-class-name m)
     1003                                          class-name))
     1004                          (return m)))))
     1005    (when method-info
     1006      (unless (and (foreign-type-= (ensure-foreign-type (objc-method-info-result-type method-info))
     1007                                   (parse-foreign-type result-type))
     1008                   (do* ((existing (objc-method-info-arglist method-info) (cdr existing))
     1009                         (proposed args (cdr proposed)))
     1010                        ((null existing) (null proposed))
     1011                     (unless (foreign-type-= (ensure-foreign-type (car existing))
     1012                                             (parse-foreign-type (car proposed)))
     1013                       (return nil))))
     1014        (cerror "Redefine existing method to have new type signature."
     1015                "The method ~c[~a ~a] is already declared to have type signature ~s; the new declaration ~s is incompatible." (if class-p #\+ #\-) class-name (objc-message-info-message-name message-info) (objc-method-info-signature method-info) (cons result-type args))
     1016        (setf (objc-method-info-arglist method-info) args
     1017              (objc-method-info-result-type method-info) result-type
     1018              (objc-method-info-signature method-info) nil
     1019              (objc-method-info-signature-info method-info) nil))
     1020      method-info)))
     1021
     1022;;; Still not right; we have to worry about type conflicts with
     1023;;; shadowed methods, as well.
    9661024(defun %declare-objc-method (message-name class-name class-p result-type args)
    9671025  (let* ((info (get-objc-message-info message-name)))
     
    9701028      (setf (gethash message-name *objc-message-info*) info))
    9711029    (let* ((was-ambiguous (getf (objc-message-info-flags info) :ambiguous))
    972            (method-info (make-objc-method-info :message-info info
    973                                                :class-name class-name
    974                                                :result-type result-type
    975                                                :arglist args
    976                                                :flags (if class-p '(:class t)))))
    977       (push method-info (objc-message-info-methods info))
     1030           (method-info (or (resolve-existing-objc-method-info info class-name class-p result-type args)
     1031                            (make-objc-method-info :message-info info
     1032                                                   :class-name class-name
     1033                                                   :result-type result-type
     1034                                                   :arglist args
     1035                                                   :flags (if class-p '(:class t))))))
     1036      (pushnew method-info (objc-message-info-methods info))
    9781037      (postprocess-objc-message-info info)
    9791038      (if (and (getf (objc-message-info-flags info) :ambiguous)
    9801039               (not was-ambiguous))
    9811040        (warn "previously declared methods on ~s all had the same type signature, but ~s introduces ambiguity" message-name method-info))
    982       info)))
     1041           
     1042      (objc-method-info-signature method-info))))
    9831043
    9841044
  • branches/objc-gf/ccl/examples/cocoa-backtrace.lisp

    r5732 r6112  
    77  (:metaclass ns:+ns-object))
    88
    9 (define-objc-method ((:unsigned length) ns-lisp-string)
     9(objc:defmethod (#/length :<NSUI>nteger) ((self ns-lisp-string))
    1010    (length (ns-lisp-string-string self)))
    1111
    12 (define-objc-method ((:unichar :character-at-index (:<NSUI>nteger index))
    13                      ns-lisp-string)
     12(objc:defmethod (#/characterAtIndex: :unichar) ((self ns-lisp-string) (index :<NSUI>nteger))
    1413  (char-code (schar (ns-lisp-string-string self) index)))
    1514
     
    3231  (:metaclass ns:+ns-object))
    3332
    34 (define-objc-method ((:id window-nib-name)
    35                      backtrace-window-controller)
     33(objc:defmethod #/windowNibName ((self backtrace-window-controller))
    3634  #@"backtrace")
    3735
     
    4543       (eql self (frame-label-controller thing))))
    4644
    47 (define-objc-method ((:void window-did-load)
    48                      backtrace-window-controller)
     45(objc:defmethod (#/windowDidLoad :void) ((self backtrace-window-controller))
    4946  (let* ((outline (slot-value self 'outline-view))
    5047         (font (default-font :name "Monaco" :size 12)))
    5148    (unless (%null-ptr-p outline)
    52       (let* ((columns (send outline 'table-columns)))
    53         (dotimes (i (send columns 'count))
    54           (let* ((column (send columns :object-at-index i))
    55                  (data-cell (send column 'data-cell)))
    56             (send data-cell :set-font font)
     49      (let* ((columns (#/tableColumns outline)))
     50        (dotimes (i (#/count columns))
     51          (let* ((column (#/objectAtIndex:  columns i))
     52                 (data-cell (#/dataCell column)))
     53            (#/setFont: data-cell font)
    5754            (when (eql i 0)
    58               (let* ((header-cell (send column 'header-cell))
     55              (let* ((header-cell (#/headerCell column))
    5956                     (inspector (backtrace-controller-inspector self))
    6057                     (break-condition
     
    6966                                break-condition))))
    7067                     
    71                 (send header-cell :set-font (default-font :attributes '(:bold)))
    72                 (send header-cell :set-string-value
    73                       (%make-nsstring break-condition-string))))))))
    74     (let* ((window (send self 'window)))
     68                (#/setFont: header-cell (default-font :attributes '(:bold)))
     69                (#/setStringValue: header-cell (%make-nsstring break-condition-string))))))))
     70    (let* ((window (#/window  self)))
    7571      (unless (%null-ptr-p window)
    7672        (let* ((context (backtrace-controller-context self))
    7773               (process (tcr->process (bt.tcr context))))
    78           (send window :set-title (%make-nsstring
    79                                    (format nil "Backtrace for ~a(~d), break level ~d"
    80                                            (process-name process)
    81                                            (process-serial-number process)
    82                                            (bt.break-level context)))))))))
     74          (#/setTitle:  window (%make-nsstring
     75                                (format nil "Backtrace for ~a(~d), break level ~d"
     76                                        (process-name process)
     77                                        (process-serial-number process)
     78                                        (bt.break-level context)))))))))
    8379
    84              
    85 (define-objc-method ((:<BOOL> :outline-view view
    86                               :is-item-expandable item)
    87                      backtrace-window-controller)
     80(objc:defmethod (#/outlineView:isItemExpandable: :<BOOL>)
     81    ((self backtrace-window-controller) view item)
    8882    (declare (ignore view))
    8983    (or (%null-ptr-p item)
    9084        (our-frame-label-p self item)))
    9185
    92 (define-objc-method ((:<NSI>nteger :outline-view view
    93                                    :number-of-children-of-item item)
    94                      backtrace-window-controller)
     86(objc:defmethod (#/outlineView:numberOfChildrenOfItem: :<NSI>nteger)
     87    ((self backtrace-window-controller) view item)
    9588    (declare (ignore view))
    9689    (let* ((inspector (backtrace-controller-inspector self)))
     
    108101               (inspector::inspector-line-count frame-inspector)))
    109102            (t -1))))
    110              
    111 (define-objc-method ((:id :outline-view view
    112                           :child (:<NSI>nteger index)
    113                           :of-item item)
    114                      backtrace-window-controller)
    115     (declare (ignore view))
     103
     104(objc:defmethod #/outlineView:child:ofItem:
     105    ((self backtrace-window-controller) view (index :<NSI>nteger) item)
     106  (declare (ignore view))
    116107  (let* ((inspector (backtrace-controller-inspector self)))
    117108    (cond ((%null-ptr-p item)
     
    154145          (t (break) (%make-nsstring "Huh?")))))
    155146
    156 (define-objc-method ((:id :outline-view view
    157                           :object-value-for-table-column column
    158                           :by-item item)
    159                      backtrace-window-controller)
    160     (declare (ignore view column))
    161     (if (%null-ptr-p item)
    162       #@"Open this"
    163       (%setf-macptr (%null-ptr) item)))
     147(objc:defmethod #/outlineView:objectValueForTableColumn:byItem:
     148    ((self backtrace-window-controller) view column item)
     149  (declare (ignore view column))
     150  (if (%null-ptr-p item)
     151    #@"Open this"
     152    (%setf-macptr (%null-ptr) item)))
    164153
    165154(defmethod initialize-instance :after ((self backtrace-window-controller)
     
    176165
    177166#+debug
    178 (define-objc-method ((:void will-load)
    179                      backtrace-window-controller)
    180   (#_NSLog #@"will load %@" :address (send self 'window-nib-name)))
     167(objc:defmethod (#/willLoad :void) ((self backtrace-window-controller))
     168  (#_NSLog #@"will load %@" :address ) #/windowNibName self))
    181169
    182170(defmethod ui-object-enter-backtrace-context ((app ns:ns-application)
  • branches/objc-gf/ccl/examples/cocoa-defaults.lisp

    r763 r6112  
    8080(defun update-cocoa-defaults ()
    8181  (update-cocoa-defaults-vector
    82    (send (@class "NSUserDefaults") 'standard-user-defaults)
     82   (#/standardUserDefaults ns:ns-user-defaults)
    8383   (apply #'vector (reverse (cocoa-defaults)))))
    8484
     
    8989             (name (cocoa-default-symbol d))
    9090             (key (objc-constant-string-nsstringptr (cocoa-default-string d))))
    91         (if (%null-ptr-p (send domain :object-for-key key))
     91        (if (%null-ptr-p (#/objectForKey:  domain key))
    9292          (progn
    93             (send domain
    94                   :set-object (%make-nsstring (format nil "~a" (cocoa-default-value d)))
    95                   :for-key key)
     93            (#/setObject:forKey: domain (%make-nsstring (format nil "~a" (cocoa-default-value d))) key)
    9694            (setq need-synch t))
    9795          (case (cocoa-default-type d)
    9896            (:int
    99              (set name (send domain :integer-for-key key)))
     97             (set name (#/integerForKey: domain key)))
    10098            (:float
    101              (set name (send domain :float-for-key key)))
     99             (set name (#/floatForKey: domain key)))
    102100            (:string
    103              (let* ((nsstring (send domain :string-for-key key)))
     101             (let* ((nsstring (#/stringForKey: domain key)))
    104102               (unless (%null-ptr-p nsstring)
    105103                 (set name (lisp-string-from-nsstring nsstring)))))))))
    106     (when need-synch (send domain 'synchronize))))
     104    (when need-synch (#/synchronize domain))))
  • branches/objc-gf/ccl/examples/cocoa-editor.lisp

    r6105 r6112  
    4343         (font (default-font :name font-name :size font-size))
    4444         (color-class (find-class 'ns:ns-color))
    45          (colors (vector (send color-class 'black-color)
    46                          (send color-class 'white-color)
    47                          (send color-class 'dark-gray-color)
    48                          (send color-class 'light-gray-color)
    49                          (send color-class 'red-color)
    50                          (send color-class 'blue-color)
    51                          (send color-class 'green-color)
    52                          (send color-class 'yellow-color)))
     45         (colors (vector (#/blackColor color-class)
     46                         (#/whiteColor  color-class)
     47                         (#/darkGrayColor color-class)
     48                         (#/lightGrayColor color-class)
     49                         (#/redColor color-class)
     50                         (#/blueColor color-class)
     51                         (#/greenColor color-class)
     52                         (#/yellowColor color-class)))
    5353         (styles (make-array (the fixnum (* 4 (length colors)))))
    5454         (bold-stroke-width 9.0f0)
     
    264264;;; Return the length of the abstract string, i.e., the number of
    265265;;; characters in the buffer (including implicit newlines.)
    266 (define-objc-method ((:<NSUI>nteger length)
    267                      hemlock-buffer-string)
     266(objc:defmethod (#/length :<NSUI>nteger) ((self hemlock-buffer-string))
    268267  (let* ((cache (hemlock-buffer-string-cache self)))
    269268    (or (buffer-cache-buflen cache)
     
    276275;;; Return the character at the specified index (as a :unichar.)
    277276
    278 (define-objc-method ((:unichar :character-at-index (:<NSUI>nteger index))
    279                      hemlock-buffer-string)
     277(objc:defmethod (#/characterAtIndex :unichar)
     278    ((self hemlock-buffer-string) (index :<NSUI>nteger))
    280279  #+debug
    281280  (#_NSLog #@"Character at index: %d" :<NSUI>nteger index)
    282281  (char-code (hemlock-char-at-index (hemlock-buffer-string-cache self) index)))
    283282
    284 
    285 (define-objc-method ((:void :get-characters ((:* :unichar) buffer) :range (:<NSR>ange r))
    286                      hemlock-buffer-string)
     283(objc:defmethod (#/getCharacters:range: :void)
     284    ((self hemlock-buffer-string)
     285     (buffer (:* :unichar))
     286     (r (:<NSR>ange)))
    287287  (let* ((cache (hemlock-buffer-string-cache self))
    288          (index (pref r :<NSR>ange.location))
    289          (length (pref r :<NSR>ange.length))
     288         (index (ns:ns-range-location r))
     289         (length (ns:ns-range-length r))
    290290         (hi::*buffer-gap-context*
    291291          (hi::buffer-gap-context (buffer-cache-buffer cache))))
     
    296296    (multiple-value-bind (line idx) (update-line-cache-for-index cache index)
    297297      (let* ((len (hemlock::line-length line)))
    298         (do* ((i 0 (1+ i))
    299               (p 0 (+ p 2)))
     298        (do* ((i 0 (1+ i)))
    300299             ((= i length))
    301300          (cond ((< idx len)
    302                  (setf (%get-unsigned-word buffer p)
     301                 (setf (paref buffer (:* :unichar) i)
    303302                       (char-code (hemlock::line-character line idx)))
    304303                 (incf idx))
    305304                (t
    306                  (setf (%get-unsigned-word buffer p)
     305                 (setf (paref buffer (:* :unichar) i)
    307306                       (char-code #\Newline)
    308307                       line (hi::line-next line)
     
    310309                  idx 0))))))))
    311310
    312 (define-objc-method ((:void :get-line-start ((:* :<NSUI>nteger) startptr)
    313                             :end ((:* :<NSUI>nteger) endptr)
    314                             :contents-end ((:* :<NSUI>nteger) contents-endptr)
    315                             :for-range (:<NSR>ange r))
    316                      hemlock-buffer-string)
     311(objc:defmethod (#/getLineStart:end:contentsEnd:forRange: :void)
     312    ((self hemlock-buffer-string)
     313     (startptr (:* :<NSUI>nteger))
     314     (endptr (:* :<NSUI>nteger))
     315     (contents-endptr (:* :<NSUI>nteger))
     316     (r :<NSR>ange))
    317317  (let* ((cache (hemlock-buffer-string-cache self))
    318318         (index (pref r :<NSR>ange.location))
     
    328328      ;; Index of the first character in the line which contains
    329329      ;; the start of the range.
    330       (setf (pref startptr :unsigned)
     330      (setf (pref startptr :<NSUI>nteger)
    331331            (buffer-cache-workline-offset cache)))
    332332    (unless (%null-ptr-p endptr)
    333333      ;; Index of the newline which terminates the line which
    334334      ;; contains the start of the range.
    335       (setf (pref endptr :unsigned)
     335      (setf (pref endptr :<NSUI>nteger)
    336336            (+ (buffer-cache-workline-offset cache)
    337337               (buffer-cache-workline-length cache))))
     
    341341      (unless (zerop length)
    342342        (update-line-cache-for-index cache (+ index length)))
    343       (setf (pref contents-endptr :unsigned)
     343      (setf (pref contents-endptr :<NSUI>nteger)
    344344            (1+ (+ (buffer-cache-workline-offset cache)
    345345                   (buffer-cache-workline-length cache)))))))
     
    351351;;; ensure that each line is terminated according to the buffer's
    352352;;; conventions.
    353 (define-objc-method ((:id :data-using-encoding (:<NSS>tring<E>ncoding encoding)
    354                           :allow-lossy-conversion (:<BOOL> flag))
    355                      hemlock-buffer-string)
     353(objc:defmethod #/dataUsingEncoding:allowLossyConversion:
     354    ((self hemlock-buffer-string)
     355     (encoding :<NSS>tring<E>ncoding)
     356     (flag :<BOOL>))
    356357  (let* ((buffer (buffer-cache-buffer (hemlock-buffer-string-cache self)))
    357358         (hi::*buffer-gap-context* (hi::buffer-gap-context buffer))
     
    363364      (case external-format
    364365        ((:unix nil)
    365          (send-super :data-using-encoding encoding :allow-lossy-conversion flag))
     366         (call-next-method encoding flag))
    366367        ((:macos :cp/m)
    367368         (let* ((cp/m-p (eq external-format :cp/m)))
     
    378379                  (data (make-objc-instance 'ns:ns-mutable-data
    379380                                            :with-length raw-length))
    380                   (bytes (send data 'mutable-bytes)))
     381                  (bytes (#/mutableBytes data)))
    381382             (do* ((line (hi::mark-line (hi::buffer-start-mark buffer))
    382383                         next)
     
    398399;;; For debugging, mostly: make the printed representation of the string
    399400;;; referenence the named Hemlock buffer.
    400 (define-objc-method ((:id description)
    401                      hemlock-buffer-string)
     401(objc:defmethod #/description ((self hemlock-buffer-string))
    402402  (let* ((cache (hemlock-buffer-string-cache self))
    403403         (b (buffer-cache-buffer cache)))
    404404    (with-cstrs ((s (format nil "~a" b)))
    405       (send (@class ns-string) :string-with-format #@"<%s for %s>"
    406         (:address (#_object_getClassName self) :address s)))))
     405      (#/stringWithFormat: ns:ns-string #@"<%s for %s>" (#_object_getClassName self) s))))
    407406
    408407
     
    416415  (:metaclass ns:+ns-object))
    417416
    418 (define-objc-method ((:<NSUI>nteger :line-break-before-index (:<NSUI>nteger index)
    419                                 :within-range (:<NSR>ange r))
    420                      hemlock-text-storage)
     417
     418;;; This is only here so that calls to it can be logged for debugging.
     419#+debug
     420(objc:defmethod (#/lineBreakBeforeIndex:withinRange: :<NSUI>nteger)
     421    ((self hemlock-text-storage)
     422     (index :<NSUI>nteger)
     423     (r :<NSR>ange))
    421424  (#_NSLog #@"Line break before index: %d within range: %@"
    422425           :unsigned index
    423426           :id (#_NSStringFromRange r))
    424   (send-super :line-break-before-index index :within-range r))
     427  (call-next-method index r))
    425428
    426429
    427430
    428431;;; Return true iff we're inside a "beginEditing/endEditing" pair
    429 (define-objc-method ((:<BOOL> editing-in-progress) hemlock-text-storage)
     432(objc:defmethod (#/editingInProgress :<BOOL>) ((self hemlock-text-storage))
    430433  (not (eql (slot-value self 'edit-count) 0)))
    431434
    432435(defun textstorage-note-insertion-at-position (self pos n)
    433   (send self
    434         :edited #$NSTextStorageEditedAttributes
    435         :range (ns-make-range pos 0)
    436         :change-in-length n)
    437   (send self
    438         :edited #$NSTextStorageEditedCharacters
    439         :range (ns-make-range pos n)
    440         :change-in-length 0))
    441 
    442 (define-objc-method ((:void :note-insertion params) hemlock-text-storage)
    443   (let* ((pos (send (send params :object-at-index 0) 'int-value))
    444          (n (send (send params :object-at-index 1) 'int-value)))
     436  (rlet ((r :ns-range))
     437    (ns:init-ns-range pos 0)
     438    (#/edited:range:changeInLength: self #$NSTextStorageEditedAttributes r n)
     439    (setf (ns:ns-range-length r) n)
     440    (#/edited:range:changeInLength: self #$NSTextStorageEditedCharacters r 0)))
     441
     442(objc:defmethod (#/noteInsertion: :void) ((self hemlock-text-storage) params)
     443  (let* ((pos (#/intValue (#/objectAtIndex: params 0)))
     444         (n (#/intValue (#/objectAtIndex: params 1))))
    445445    (textstorage-note-insertion-at-position self pos n)))
    446446
    447 (define-objc-method ((:void :note-deletion params) hemlock-text-storage)
    448   (let* ((pos (send (send params :object-at-index 0) 'int-value))
    449          (n (send (send params :object-at-index 1) 'int-value)))
    450     (send self
    451           :edited #$NSTextStorageEditedCharacters
    452           :range (ns-make-range pos n)
    453           :change-in-length (- n))
    454     (let* ((display (hemlock-buffer-string-cache (send self 'string))))
     447(objc:defmethod (#/noteDeletion: :void) ((self hemlock-text-storage) params)
     448  (let* ((pos (#/intValue (#/objectAtIndex: params 0)))
     449         (n (#/intValue (#/objectAtIndex: params 1))))
     450    (rlet ((range :ns-range :location pos :length n))
     451      (#/edited:range:changeInLength: self #$NSTextStorageEditedCharacters r (- n)))
     452    (let* ((display (hemlock-buffer-string-cache (#/string self))))
    455453      (reset-buffer-cache display)
    456454      (update-line-cache-for-index display pos))))
    457455
    458 (define-objc-method ((:void :note-modification params) hemlock-text-storage)
    459   (let* ((pos (send (send params :object-at-index 0) 'int-value))
    460          (n (send (send params :object-at-index 1) 'int-value)))
     456(objc:defmethod (#/noteModification: :void) ((self hemlock-text-storage) params)
     457  (let* ((pos (#/intValue (#/objectAtIndex: params 0)))
     458         (n (#/intValue (#/objectAtIndex: params 1))))
    461459    #+debug
    462460    (#_NSLog #@"Note modification: pos = %d, n = %d" :int pos :int n)
    463     (send self
    464           :edited (logior #$NSTextStorageEditedCharacters
    465                           #$NSTextStorageEditedAttributes)
    466           :range (ns-make-range pos n)
    467           :change-in-length 0)))
    468 
    469 (define-objc-method ((:void :note-attr-change params) hemlock-text-storage)
    470   (let* ((pos (send (send params :object-at-index 0) 'int-value))
    471          (n (send (send params :object-at-index 1) 'int-value)))
     461    (rlet ((range :ns-range :location pos :length n))
     462      (#/edited:range:changeInLength: self (logior #$NSTextStorageEditedCharacters
     463                                                  #$NSTextStorageEditedAttributes) range 0))))
     464
     465(objc:defmethod (#/noteAttrChange :void) ((self hemlock-text-storage) params)
     466  (let* ((pos (#/intValue (#/objectAtIndex: params 0)))
     467         (n (#/intValue (#/objectAtIndex: params 1))))
    472468    #+debug (#_NSLog #@"attribute-change at %d/%d" :int pos :int n)
    473     (send self
    474           :edited #$NSTextStorageEditedAttributes
    475           :range (ns-make-range pos n)
    476           :change-in-length 0)))
    477 
    478 (define-objc-method ((:void begin-editing) hemlock-text-storage)
     469    (rlet ((range :ns-range :location pos :length n))
     470      (#/edited:range:changeInLength: self #$NSTextStorageEditedAttributes range 0))))
     471
     472(objc:defmethod (#/beginEditing :void) ((self hemlock-text-storage))
    479473  #+debug
    480474  (#_NSLog #@"begin-editing")
     
    482476  #+debug
    483477  (#_NSLog #@"after beginEditing edit-count now = %d" :int (slot-value self 'edit-count))
    484   (send-super 'begin-editing))
    485 
    486 (define-objc-method ((:void end-editing) hemlock-text-storage)
     478  (call-next-method))
     479
     480(objc:defmethod (#/endEditing :void) ((self hemlock-text-storage))
    487481  #+debug
    488482  (#_NSLog #@"end-editing")
    489   (send-super 'end-editing)
     483  (call-next-method)
    490484  (decf (slot-value self 'edit-count))
    491485  #+debug
     
    493487
    494488;;; Return true iff we're inside a "beginEditing/endEditing" pair
    495 (define-objc-method ((:<BOOL> editing-in-progress) hemlock-text-storage)
     489(objc:defmethod (#/editingInProgress :<BOOL>) ((self hemlock-text-storage))
    496490  (not (eql (slot-value self 'edit-count) 0)))
    497491
     
    500494;;; Access the string.  It'd be nice if this was a generic function;
    501495;;; we could have just made a reader method in the class definition.
    502 (define-objc-method ((:id string) hemlock-text-storage)
     496(objc:defmethod #/string ((self hemlock-text-storage))
    503497  (slot-value self 'string))
    504498
    505 (define-objc-method ((:id :init-with-string s) hemlock-text-storage)
    506   (let* ((newself (send-super 'init)))
     499(objc:defmethod #/initWithString: ((self hemlock-text-storage) s)
     500  (let* ((newself (call-next-method)))
    507501    (setf (slot-value newself 'string) s)
    508502    newself))
     
    552546      (svref *styles* style))))
    553547
    554 (define-objc-method ((:void :replace-characters-in-range (:<NSR>ange r)
    555                             :with-string string)
    556                      hemlock-text-storage)
    557   (let* ((cache (hemlock-buffer-string-cache (send self 'string)))
     548(objc:defmethod (#/replaceCharactersInRange:withString: :void)
     549    ((self hemlock-text-storage) (r :<NSR>ange) string)
     550  (let* ((cache (hemlock-buffer-string-cache (#/string  self)))
    558551         (buffer (if cache (buffer-cache-buffer cache)))
    559552         (hi::*buffer-gap-context* (hi::buffer-gap-context buffer))
     
    563556         (point (hi::buffer-point buffer))
    564557         input-mark)
    565 
    566558    ;;
    567559    ;; special behavior for listener windows.
     
    587579
    588580;;; I'm not sure if we want the text system to be able to change
    589 ;;; attributes in the buffer.
    590 (define-objc-method ((:void :set-attributes attributes
    591                             :range (:<NSR>ange r))
    592                      hemlock-text-storage)
     581;;; attributes in the buffer.  This method is only here so we can
     582;;; see if/when it tries to do so.
     583(objc:defmethod (#/setAttributes:range: :void) ((self hemlock-text-storage)
     584                                                attributes
     585                                                (r :<NSR>ange))
    593586  (declare (ignorable attributes r))
    594587  #+debug
     
    599592
    600593(defun for-each-textview-using-storage (textstorage f)
    601   (let* ((layouts (send textstorage 'layout-managers)))
     594  (let* ((layouts (#/layoutManagers textstorage)))
    602595    (unless (%null-ptr-p layouts)
    603       (dotimes (i (send layouts 'count))
    604         (let* ((layout (send layouts :object-at-index i))
    605                (containers (send layout 'text-containers)))
     596      (dotimes (i (#/count layouts))
     597        (let* ((layout (#/objectAtIndex: layouts i))
     598               (containers (#/textContainers layout)))
    606599          (unless (%null-ptr-p containers)
    607             (dotimes (j (send containers 'count))
    608               (let* ((container (send containers :object-at-index j))
    609                      (tv (send container 'text-view)))
     600            (dotimes (j (#/count containers))
     601              (let* ((container (#/objectAtIndex: containers j))
     602                     (tv (#/textView container)))
    610603                (funcall f tv)))))))))
    611604
    612605;;; Again, it's helpful to see the buffer name when debugging.
    613 (define-objc-method ((:id description)
    614                      hemlock-text-storage)
    615   (send (@class ns-string) :string-with-format #@"%s : string %@"
    616         (:address (#_object_getClassName self) :id (slot-value self 'string))))
     606(objc:defmethod #/description ((self hemlock-text-storage))
     607  (#/stringWithFormat: ns:ns-string #@"%s : string %@" (#_object_getClassName self) (slot-value self 'string)))
    617608
    618609;;; This needs to happen on the main thread.
    619 (define-objc-method ((:void ensure-selection-visible)
    620                      hemlock-text-storage)
     610(objc:defmethod (#/ensureSelectionVisible :void) ((self hemlock-text-storage))
    621611  (for-each-textview-using-storage
    622612   self
    623613   #'(lambda (tv)
    624        (send tv :scroll-range-to-visible (send tv 'selected-range)))))
     614       (#/scrollRangeToVisible: tv (#/selectedRange tv)))))
    625615
    626616
     
    661651(def-cocoa-default *layout-text-in-background* :int 1 "When non-zero, do text layout when idle.")
    662652
    663 (define-objc-method ((:void :layout-manager layout
    664                             :did-complete-layout-for-text-container cont
    665                             :at-end (:<BOOL> flag))
    666                      hemlock-textstorage-text-view)
    667   (declare (ignore cont))
     653(objc:defmethod (#/layoutManager:didCompleteLayoutForTextContainer:atEnd: :void)
     654    ((self hemlock-textstorage-text-view) layout cont (flag :<BOOL>))
     655  (declare (ignore cont flag))
    668656  (when (zerop *layout-text-in-background*)
    669     (send layout :set-delegate (%null-ptr))
    670     (send layout :set-background-layout-enabled nil)))
     657    (#/setDelegate: layout (%null-ptr))
     658    (#/setBackgroundLayoutEnabled: layout nil)))
    671659   
    672660;;; Note changes to the textview's background color; record them
    673661;;; as the value of the "temporary" foreground color (for blinking).
    674 (define-objc-method ((:void :set-background-color color)
    675                      hemlock-textstorage-text-view)
     662(objc:defmethod (#/setBackgroundColor: :void)
     663    ((self hemlock-textstorage-text-view) color)
    676664  (setf (text-view-blink-color self) color)
    677   (send-super :set-background-color color))
     665  (call-next-method color))
    678666
    679667;;; Maybe cause 1 character in the textview to blink (by drawing an empty
    680668;;; character rectangle) in synch with the insertion point.
    681669
    682 (define-objc-method ((:void :draw-insertion-point-in-rect (:<NSR>ect r)
    683                             :color color
    684                             :turned-on (:<BOOL> flag))
    685                      hemlock-textstorage-text-view)
    686   (unless (send (send self 'text-storage) 'editing-in-progress)
     670(objc:defmethod (#/drawInsertionPointInRect:color:turnedOn: :void)
     671    ((self hemlock-textstorage-text-view)
     672     (r :<NSR>ect)
     673     color
     674     (flag :<BOOL>))
     675  (unless (#/editingInProgress (#/textStorage self))
    687676    (unless (eql #$NO (text-view-blink-enabled self))
    688       (let* ((layout (send self 'layout-manager))
    689              (container (send self 'text-container))
     677      (let* ((layout (#/layoutManager self))
     678             (container (#/textContainer self))
    690679             (blink-color (text-view-blink-color self)))
    691680        ;; We toggle the blinked character "off" by setting its
     
    693682        ;; The blinked character should be "on" whenever the insertion
    694683        ;; point is drawn as "off"
    695         (slet ((glyph-range
    696                 (send layout
    697                       :glyph-range-for-character-range
    698                       (ns-make-range (text-view-blink-location self) 1)
    699                       :actual-character-range (%null-ptr))))
    700           #+debug (#_NSLog #@"Flag = %d, location = %d" :<BOOL> (if flag #$YES #$NO) :int (text-view-blink-location self))
    701           (slet ((rect (send layout
    702                              :bounding-rect-for-glyph-range glyph-range
    703                              :in-text-container container)))
    704             (send (the ns:ns-color blink-color) 'set)
    705             (#_NSRectFill rect))
     684        (rlet  ((char-range :ns-range))
     685          (ns:init-ns-range char-range (text-view-blink-location self) 1)
     686          (let* ((glyph-range (#/glyphRangeForCharacterRange:actualCharacterRange:
     687                               layout
     688                               char-range
     689                               (%null-ptr))))
     690            #+debug (#_NSLog #@"Flag = %d, location = %d" :<BOOL> (if flag #$YES #$NO) :int (text-view-blink-location self))
     691            (let* ((rect (#/boundingRectForGlyphRange:inTextContainer:
     692                          layout
     693                          glyph-range
     694                          container)))
     695              (#/set blink-color)
     696              (#_NSRectFill rect))
    706697          (if flag
    707             (send layout
    708                   :draw-glyphs-for-glyph-range glyph-range
    709                   :at-point  (send self 'text-container-origin)))
    710           )))
    711     (send-super :draw-insertion-point-in-rect r
    712                 :color color
    713                 :turned-on flag)))
     698            (#/drawGlyphsForGlyphRange:atPoint: layout glyph-range (#/textContainerOrigin self)))))))
     699    (call-next-method r color flag)))
    714700               
    715701(defmethod disable-blink ((self hemlock-textstorage-text-view))
     
    718704    ;; Force the blinked character to be redrawn.  Let the text
    719705    ;; system do the drawing.
    720     (let* ((layout (send self 'layout-manager)))
    721       (send layout :invalidate-display-for-character-range
    722             (ns-make-range (text-view-blink-location self) 1)))))
     706    (let* ((layout (#/layoutManager self)))
     707      (rlet ((invalid-range :ns-range
     708                            :location  (text-view-blink-location self)
     709                            :length 1))
     710        (#/invalidateDisplayForCharacterRange: layout invalid-range)))))
    723711
    724712(defmethod update-blink ((self hemlock-textstorage-text-view))
    725713  (disable-blink self)
    726   (let* ((d (hemlock-buffer-string-cache (send self 'string)))
     714  (let* ((d (hemlock-buffer-string-cache (#/string self)))
    727715         (buffer (buffer-cache-buffer d)))
    728716    (when (and buffer (string= (hi::buffer-major-mode buffer) "Lisp"))
     
    752740;;; affinity is affinity.  This should never be called from any Cocoa
    753741;;; event handler; it should not call anything that'll try to set the
    754 ;;; underlying buffer's point and/or mark.
    755 (define-objc-method ((:void :update-selection (:int pos)
    756                             :length (:int len)
    757                             :affinity (:<NSS>election<A>ffinity affinity))
    758                      hemlock-textstorage-text-view)
     742;;; underlying buffer's point and/or mark
     743
     744(objc:defmethod (#/updateSelection:length:affinity: :void)
     745    ((self hemlock-textstorage-text-view)
     746     (pos :int)
     747     (length :int)
     748     (affinity :<NSS>election<A>ffinity))
    759749  (when (eql len 0)
    760750    (update-blink self))
    761   (slet ((range (ns-make-range pos len)))
    762     (send-super :set-selected-range range
    763                 :affinity affinity
    764                 :still-selecting nil)
    765     (send self :scroll-range-to-visible range)))
     751  (rlet ((range :ns-range :location pos :length len))
     752    (%call-next-objc-method self
     753                            hemlock-textstorage-text-view
     754                            (@selector #/setSelectedRange:affinity:stillSelecting:)
     755                            '(:void :<NSR>ange :<NSS>election<A>ffinity :<BOOL>)
     756                            range
     757                            affinity
     758                            nil)
     759    (#/scrollRangeToVisible self range)))
    766760 
    767761;;; A specialized NSTextView. The NSTextView is part of the "pane"
     
    773767;;; Access the underlying buffer in one swell foop.
    774768(defmethod text-view-buffer ((self hemlock-text-view))
    775   (buffer-cache-buffer (hemlock-buffer-string-cache (send (send self 'text-storage) 'string))))
    776 
    777 (define-objc-method ((:void :set-string s)
    778                      hemlock-textstorage-text-view)
     769  (buffer-cache-buffer (hemlock-buffer-string-cache (#/string (#/textStorage self)))))
     770
     771(objc:defmethod (#/setString :void) ((self hemlock-textstorage-text-view))
     772  #+debug
    779773  (#_NSLog #@"hemlock-text-view %@ string set to %@" :id self :id s)
    780   (send-super :set-string s))
     774  (call-next-method))
    781775
    782776(define-objc-method (((:struct :_<NSR>ange r)
     
    791785      (when (and (eql 0 length)              ; not extending existing selection
    792786                 (not (eql g #$NSSelectByCharacter)))
    793         (let* ((textstorage (send self 'text-storage))
     787        (let* ((textstorage (#/textStorage self))
    794788               (cache (hemlock-buffer-string-cache (send textstorage 'string)))
    795789               (buffer (if cache (buffer-cache-buffer cache))))
     
    826820;;; Translate a keyDown NSEvent to a Hemlock key-event.
    827821(defun nsevent-to-key-event (nsevent)
    828   (let* ((unmodchars (send nsevent 'characters-ignoring-modifiers))
     822  (let* ((unmodchars (#/charactersIgnoringModifiers nsevent))
    829823         (n (if (%null-ptr-p unmodchars)
    830824              0
    831               (send (the ns:ns-string unmodchars) 'length)))
     825              (#/length unmodchars)))
    832826         (c (if (eql n 1)
    833               (send unmodchars :character-at-index 0))))
     827              (#/characterAtIndex: unmodchars 0))))
    834828    (when c
    835829      (let* ((bits 0)
    836              (modifiers (send nsevent 'modifier-flags))
     830             (modifiers (#/modifierFlags nsevent))
    837831             (useful-modifiers (logandc2 modifiers
    838832                                         (logior #$NSShiftKeyMask
     
    849843  (let* ((buffer (text-view-buffer self)))
    850844    (when buffer
    851       (let* ((q (hemlock-frame-event-queue (send self 'window))))
     845      (let* ((q (hemlock-frame-event-queue (#/window self))))
    852846        (hi::enqueue-key-event q (nsevent-to-key-event event))))))
    853847
    854848(defun enqueue-buffer-operation (buffer thunk)
    855849  (dolist (w (hi::buffer-windows buffer))
    856     (let* ((q (hemlock-frame-event-queue (send w 'window)))
     850    (let* ((q (hemlock-frame-event-queue (#/window w)))
    857851           (op (hi::make-buffer-operation :thunk thunk)))
    858852      (hi::event-queue-insert q op))))
     
    863857;;; interpreter.
    864858
    865 (define-objc-method ((:void :key-down event)
    866                      hemlock-text-view)
     859(objc:defmethod (#/keyDownEvent: :void) ((self hemlock-text-view) event)
    867860  (pass-key-down-event-to-hemlock self event))
    868861
     
    870863;;; This is called in response to a mouse click or other event; it shouldn't
    871864;;; be called from the Hemlock side of things.
    872 (define-objc-method ((:void :set-selected-range (:<NSR>ange r)
    873                             :affinity (:<NSS>election<A>ffinity affinity)
    874                             :still-selecting (:<BOOL> still-selecting))
    875                      hemlock-text-view)
     865
     866(objc:defmethod (#/setSelectedRange:affinity:stillSelecting: :void)
     867    ((self hemlock-text-view)
     868     (r :<NSR>ange)
     869     (affinity :<NSS>election<A>ffinity)
     870     (still-selecting :<BOOL>))
    876871  #+debug
    877872  (#_NSLog #@"Set selected range called: location = %d, length = %d, affinity = %d, still-selecting = %d"
     
    882877  #+debug
    883878  (#_NSLog #@"text view string = %@, textstorage string = %@"
    884            :id (send self 'string)
    885            :id (send (send self 'text-storage) 'string))
    886   (unless (send (send self 'text-storage) 'editing-in-progress)
    887     (let* ((d (hemlock-buffer-string-cache (send self 'string)))
     879           :id (#/string self)
     880           :id (#/string (#/textStorage self)))
     881  (unless (#/editingInProgress (#/textStorage self))
     882    (let* ((d (hemlock-buffer-string-cache (#/string self)))
    888883           (buffer (buffer-cache-buffer d))
    889884           (hi::*buffer-gap-context* (hi::buffer-gap-context buffer))
     
    908903             ;; d: range: {n1,m} still-selecting: false  [ rarely repeats ]
    909904             ;;
    910              ;; (Sadly, "affinity" doesn't tell us anything interesting.
     905             ;; (Sadly, "affinity" doesn't tell us anything interesting.)
    911906             ;; We've handled a and b in the clause above; after handling
    912907             ;; b, point references buffer position n0 and the
     
    940935                                                                  selection-end)))
    941936                   (hemlock::%buffer-push-buffer-mark buffer mark t)))))))
    942   (send-super :set-selected-range r
    943               :affinity affinity
    944               :still-selecting still-selecting))
     937  (call-next-method r affinity still-selecting))
    945938
    946939
     
    992985      (unless *modeline-text-attributes*
    993986        (setq *modeline-text-attributes*
    994               (create-text-attributes :color (send (@class "NSColor") 'black-color)
     987              (create-text-attributes :color (#/blackColor ns:ns-color)
    995988                                      :font (default-font
    996989                                              :name *modeline-font-name*
     
    1004997                                   buffer pane))
    1005998                      (hi::buffer-modeline-fields buffer)))))
    1006         (send (%make-nsstring string)
    1007               :draw-at-point (ns-make-point +cgfloat-zero+ +cgfloat-zero+)
    1008               :with-attributes *modeline-text-attributes*)))))
     999        (rletZ ((zpoint :ns-point))
     1000          (#/drawAtPoint:withAttributes: (%make-nsstring string)
     1001                                         zpoint
     1002                                         *modeline-text-attributes*))))))
    10091003
    10101004;;; Draw the underlying buffer's modeline string on a white background
    10111005;;; with a bezeled border around it.
    1012 (define-objc-method ((:void :draw-rect (:<NSR>ect rect))
    1013                      modeline-view)
     1006(objc:defmethod (#/drawRect: :void) ((self modeline-view) (rect :<NSR>ect))
    10141007  (declare (ignore rect))
    1015   (slet ((frame (send self 'bounds)))
     1008  (let* ((frame (#/bounds self)))
    10161009     (#_NSDrawWhiteBezel frame frame)
    10171010     (draw-modeline-string self)))
     
    10361029;;; modeline view, as well.
    10371030
    1038 (define-objc-method ((:id :init-with-frame (:<NSR>ect frame))
    1039                      modeline-scroll-view)
    1040     (let* ((v (send-super :init-with-frame frame)))
     1031(objc:defmethod #/initWithFrame: ((self modeline-scroll-view) (frame :<NSR>ect))
     1032    (let* ((v (call-next-method frame)))
    10411033      (when v
    10421034        (let* ((modeline (make-objc-instance 'modeline-view)))
    1043           (send v :add-subview modeline)
     1035          (#/addSubview: v modeline)
    10441036          (setf (scroll-view-modeline v) modeline)))
    10451037      v))
     
    10491041;;; scroll bar and place the modeline view there.
    10501042
    1051 (define-objc-method ((:void tile) modeline-scroll-view)
    1052   (send-super 'tile)
     1043(objc:defmethod (#/tile :void) ((self modeline-scroll-view))
     1044  (call-next-method)
    10531045  (let* ((modeline (scroll-view-modeline self)))
    1054     (when (and (send self 'has-horizontal-scroller)
     1046    (when (and (#/hasHorizontalScroller self)
    10551047               (not (%null-ptr-p modeline)))
    1056       (let* ((hscroll (send self 'horizontal-scroller)))
    1057         (slet ((scrollbar-frame (send hscroll 'frame))
    1058                (modeline-frame (send hscroll 'frame))) ; sic
    1059            (let* ((modeline-width (* (pref modeline-frame
    1060                                            :<NSR>ect.size.width)
    1061                                      0.75f0)))
    1062              (declare (type cgfloat modeline-width))
    1063              (setf (pref modeline-frame :<NSR>ect.size.width)
    1064                    modeline-width
    1065                    (the cgfloat
    1066                      (pref scrollbar-frame :<NSR>ect.size.width))
    1067                    (- (the cgfloat
    1068                         (pref scrollbar-frame :<NSR>ect.size.width))
    1069                       modeline-width)
    1070                    (the cg-float
    1071                      (pref scrollbar-frame :<NSR>ect.origin.x))
    1072                    (+ (the cgfloat
    1073                         (pref scrollbar-frame :<NSR>ect.origin.x))
    1074                       modeline-width))
    1075              (send hscroll :set-frame scrollbar-frame)
    1076              (send modeline :set-frame modeline-frame)))))))
     1048      (let* ((hscroll (#/horizontalScroller self))
     1049             (scrollbar-frame (#/frame hscroll))
     1050             (modeline-frame (#/frame hscroll)) ; sic
     1051             (modeline-width (* (pref modeline-frame
     1052                                      :<NSR>ect.size.width)
     1053                                0.75f0)))
     1054        (declare (type cgfloat modeline-width))
     1055        (setf (pref modeline-frame :<NSR>ect.size.width)
     1056              modeline-width
     1057              (the cgfloat
     1058                (pref scrollbar-frame :<NSR>ect.size.width))
     1059              (- (the cgfloat
     1060                   (pref scrollbar-frame :<NSR>ect.size.width))
     1061                 modeline-width)
     1062              (the cg-float
     1063                (pref scrollbar-frame :<NSR>ect.origin.x))
     1064              (+ (the cgfloat
     1065                   (pref scrollbar-frame :<NSR>ect.origin.x))
     1066                 modeline-width))
     1067        (#/setFrame: hscroll scrollbar-frame)
     1068        (#/setFrame: modeline modeline-frame)))))
    10771069
    10781070;;; We want to constrain the scrolling that happens under program control,
     
    11161108
    11171109(defun hi::invalidate-modeline (pane)
    1118   (send (text-pane-mode-line pane) :set-needs-display t))
     1110  (#/setNeedsDisplay: (text-pane-mode-line pane) t))
    11191111
    11201112(def-cocoa-default *text-pane-margin-width* :float 0.0f0 "width of indented margin around text pane")
     
    16371629(defun hi::document-begin-editing (document)
    16381630  #-all-in-cocoa-thread
    1639   (send (slot-value document 'textstorage) 'begin-editing)
     1631  (#/beginEditing (slot-value document 'textstorage))
    16401632  #+all-in-cocoa-thread
    1641   (send (slot-value document 'textstorage)
    1642         :perform-selector-on-main-thread
    1643         (@selector "beginEditing")
    1644         :with-object (%null-ptr)
    1645         :wait-until-done t))
     1633  (#/performSelectorOnMainThread:withObject:waitUntilDone:
     1634   (slot-value document 'textstorage)
     1635        (@selector #/beginEditing)
     1636        (%null-ptr)
     1637        t))
    16461638
    16471639(defun document-edit-level (document)
    16481640  (slot-value (slot-value document 'textstorage) 'edit-count))
    1649 
    1650 
    16511641
    16521642(defun hi::document-end-editing (document)
     
    19811971
    19821972#+experimental
    1983 (define-objc-method ((:<BOOL> :write-with-backup-to-file path
    1984                               :of-type type
    1985                               :save-operation (:<NSS>ave<O>peration<T>ype save-operation))
    1986                      hemlock-editor-document)
     1973(objc:defmethod (#/writeWithBackupToFile:ofType:saveOperation: :<BOOL>)
     1974    ((self hemlock-editor-document) path type (save-operation :<NSS>ave<O>peration<T>ype))
    19871975  #+debug
    19881976  (#_NSLog #@"saving file to %@" :id path)
    1989   (send-super :write-with-backup-to-file path :of-type type :save-operation save-operation))
     1977  (call-next-method path type save-operation))
    19901978
    19911979;;; This should be a preference.
  • branches/objc-gf/ccl/examples/cocoa-listener.lisp

    r5731 r6112  
    6363                 (when doc
    6464                   (setf (hi::buffer-process buf) nil)
    65                    (send doc
    66                          :perform-selector-on-main-thread (@selector "close")
    67                          :with-object (%null-ptr)
    68                          :wait-until-done nil))))
     65                   (#/performSelectorOnMainThread:withObject:waitUntilDone:
     66                    doc
     67                    (@selector #/close)
     68                    (%null-ptr)
     69                    nil))))
    6970           :initial-function
    7071           #'(lambda ()
     
    8889;;; Listener documents are never (or always) ediited.  Don't cause their
    8990;;; close boxes to be highlighted.
    90 (define-objc-method ((:void :set-document-edited (:<BOOL> edited))
    91                      hemlock-listener-window-controller)
     91(objc:defmethod (#/setDocumentEdited: :void)
     92    ((self hemlock-listener-window-controller) (:<BOOL> edited))
    9293  (declare (ignorable edited)))
    9394 
    9495
    95 (define-objc-method ((:id :init-with-window w)
    96                      hemlock-listener-window-controller)
    97   (let* ((self (send-super :init-with-window w)))
    98     (unless (%null-ptr-p self)
     96(objc:defmethod #/initWithWindow: ((self hemlock-listener-window-controller) w)
     97  (let* ((new (call-next-method w)))
     98    (unless (%null-ptr-p new)
    9999      (multiple-value-bind (server client) (ignore-errors (open-pty-pair))
    100100        (when server
     
    103103                      :with-file-descriptor (setup-server-pty server)
    104104                      :close-on-dealloc t)))
    105             (setf (slot-value self 'filehandle) fh)
    106             (setf (slot-value self 'clientfd) (setup-client-pty client))
    107             (send (send (@class ns-notification-center) 'default-center)
    108                   :add-observer self
    109                   :selector (@selector "gotData:")
    110                   :name #&NSFileHandleReadCompletionNotification
    111                   :object fh)
    112             (send fh 'read-in-background-and-notify)))))
    113     self))
    114 
    115 (define-objc-method ((:void :got-data notification)
    116                      hemlock-listener-window-controller)
     105            (setf (slot-value new 'filehandle) fh)
     106            (setf (slot-value new 'clientfd) (setup-client-pty client))
     107            (#/addObserver:selector:name:object:
     108             (#/defaultCenter ns:ns-notification-center)
     109             new
     110             (@selector #/gotData:)
     111             #&NSFileHandleReadCompletionNotification
     112             fh)
     113            (#/readInBackgroundAndNotify fh)))))
     114    new))
     115
     116(objc:defmethod (#/gotData: :void) ((self hemlock-listener-window-controller)
     117                                    notification)
    117118  (with-slots (filehandle) self
    118     (let* ((data (send (send notification 'user-info)
    119                        :object-for-key #&NSFileHandleNotificationDataItem))
    120            (document (send self 'document))
    121            (data-length (send (the ns:ns-data data) 'length))
     119    (let* ((data (#/objectForKey: (#/userInfo notification)
     120                                  #&NSFileHandleNotificationDataItem))
     121           (document (#/document self))
     122           (data-length (#/length data))
    122123           (buffer (hemlock-document-buffer document))
    123            (string (%str-from-ptr (send data 'bytes) data-length))
     124           (string (%str-from-ptr (#/bytes data) data-length))
    124125           (fh filehandle))
    125126      (enqueue-buffer-operation
     
    127128       #'(lambda ()
    128129           (hemlock::append-buffer-output buffer string)))
    129       (send fh 'read-in-background-and-notify))))
     130      (#/readInBackgroundAndNotify fh))))
    130131             
    131132
    132133
    133 (define-objc-method ((:void dealloc) hemlock-listener-window-controller)
    134   (send (send (@class ns-notification-center) 'default-center)
    135         :remove-observer self)
    136   (send-super 'dealloc))
     134(objc:defmethod (#/dealloc :void) ((self hemlock-listener-window-controller))
     135  (#/removeObserver: (#/defaultCenter ns:ns-notification-center) self)
     136  (call-next-method))
    137137
    138138
     
    146146
    147147(defmethod textview-background-color ((doc hemlock-listener-document))
    148   (send (find-class 'ns:ns-color)
    149         :color-with-calibrated-red (float *listener-background-red-component* +cgfloat-zero+)
    150         :green (float *listener-background-green-component* +cgfloat-zero+)
    151         :blue (float *listener-background-blue-component* +cgfloat-zero+)
    152         :alpha (float *listener-background-alpha-component* +cgfloat-zero+)))
     148  (#/colorWithCalibratedRed:green:blue:alpha:
     149   ns:ns-color
     150   (float *listener-background-red-component* +cgfloat-zero+)
     151   (float *listener-background-green-component* +cgfloat-zero+)
     152   (float *listener-background-blue-component* +cgfloat-zero+)
     153   (float *listener-background-alpha-component* +cgfloat-zero+)))
    153154
    154155
    155156(defun hemlock::listener-document-send-string (document string)
    156   (let* ((controller (send (send document 'window-controllers)
    157                           :object-at-index 0))
     157  (let* ((controller (#/objectAtIndex: (#/windowControllers document) 0))
    158158         (filehandle (slot-value controller 'filehandle))
    159159         (len (length string))
    160          (data (send (make-objc-instance 'ns-mutable-data
    161                                          :with-length len) 'autorelease))
    162          (bytes (send data 'mutable-bytes)))
    163     (declare (type ns:ns-file-handle filehandle))
     160         (data (#/autorelease (make-objc-instance 'ns-mutable-data
     161                                                  :with-length len)))
     162         (bytes (#/mutableBytes data)))
    164163    (%cstr-pointer string bytes nil)
    165     (send filehandle :write-data data)
    166     (send filehandle 'synchronize-file)))
    167 
    168 
    169 (define-objc-class-method ((:id top-listener) hemlock-listener-document)
    170   (let* ((all-documents (send *NSApp* 'ordered-Documents)))
    171     (dotimes (i (send all-documents 'count) (%null-ptr))
    172       (let* ((doc (send all-documents :object-at-index i)))
    173         (when (eql (send doc 'class) self)
     164    (#/writeData: filehandle data)
     165    (#/synchronizeFile filehandle)))
     166
     167
     168(objc:defmethod #/topListener ((self hemlock-listener-document))
     169  (let* ((all-documents (#/orderedDocuments *NSApp*)))
     170    (dotimes (i (#/count all-documents) (%null-ptr))
     171      (let* ((doc (#/objectAtIndex: all-documents i)))
     172        (when (eql (#/class doc) self)
    174173          (return doc))))))
    175174
    176175(defun symbol-value-in-top-listener-process (symbol)
    177   (let* ((listenerdoc (send (@class hemlock-listener-document) 'top-listener))
     176  (let* ((listenerdoc (#/topListener hemlock-listener-document))
    178177         (buffer (unless (%null-ptr-p listenerdoc)
    179178                   (hemlock-document-buffer listenerdoc)))
     
    185184
    186185
    187 (define-objc-method ((:<BOOL> is-document-edited) hemlock-listener-document)
     186(objc:defmethod (#/isDocumentEdited :<BOOL>) ((self hemlock-listener-document))
    188187  nil)
    189188
    190 
    191 (define-objc-method ((:id init)
    192                      hemlock-listener-document)
    193   (let* ((doc (send-super 'init)))
     189(objc:defmethod #/init ((self hemlock-listener-document))
     190  (let* ((doc (call-next-method)))
    194191    (unless (%null-ptr-p doc)
    195192      (let* ((listener-name (if (eql 1 (incf *cocoa-listener-count*))
     
    199196             (buffer (hemlock-document-buffer doc)))
    200197        (setf (slot-value (slot-value self 'textstorage) 'append-edits) 1)
    201         (send doc :set-file-name  (%make-nsstring listener-name))
     198        (#/setFileName: doc  (%make-nsstring listener-name))
    202199        (setf (hi::buffer-pathname buffer) nil
    203200              (hi::buffer-minor-mode buffer "Listener") t
     
    213210(defloadvar *next-listener-y-pos* nil) ; likewise
    214211
    215 (define-objc-method ((:void make-window-controllers) hemlock-listener-document)
     212(objc:defmethod (#/makeWindowControllers :void) ((self hemlock-listener-document))
    216213  (let* ((textstorage (slot-value self 'textstorage))
    217214         (window (%hemlock-frame-for-textstorage
    218                                     textstorage
    219                                     *listener-columns*
    220                                     *listener-rows*
    221                                     t
    222                                     (textview-background-color self)))
     215                  textstorage
     216                  *listener-columns*
     217                  *listener-rows*
     218                  t
     219                  (textview-background-color self)))
    223220         (controller (make-objc-instance
    224221                      'hemlock-listener-window-controller
    225222                      :with-window window))
    226223         (listener-name (hi::buffer-name (hemlock-document-buffer self))))
    227     (let* ((layout-managers (send textstorage 'layout-managers)))
    228       (dotimes (i (send layout-managers 'count))
    229         (let* ((layout (send layout-managers :object-at-index i)))
    230           (send layout :set-background-layout-enabled nil))))
    231     (send self :add-window-controller controller)
    232     (send controller 'release)
    233     (slet ((current-point (ns-make-point (or *next-listener-x-pos*
    234                                              (float *initial-listener-x-pos*
    235                                                     +cgfloat-zero+))
    236                                          (or *next-listener-y-pos*
    237                                              (float *initial-listener-y-pos*
    238                                                     +cgfloat-zero+)))))
    239       (slet ((new-point (send window
    240                               :cascade-top-left-from-point current-point)))
    241         (setf *next-listener-x-pos* (pref new-point :<NSP>oint.x)
    242               *next-listener-y-pos* (pref new-point :<NSP>oint.y))))
     224    ;; Disabling background layout on listeners is an attempt to work
     225    ;; around a bug.  The bug's probably gone ...
     226    (let* ((layout-managers (#/layoutManagers textstorage)))
     227      (dotimes (i (#/count layout-managers))
     228        (let* ((layout (#/objectAtIndex: layout-managers i)))
     229          (#/setBackgroundLayoutEnabled: layout nil))))
     230    (#/addWindowController: self controller)
     231    (#/release controller)
     232    (rlet ((current-point :ns-point))
     233      (ns:init-ns-point current-point
     234                        (or *next-listener-x-pos* *initial-listener-x-pos*)
     235                        (or *next-listener-y-pos* *initial-listener-y-pos*))
     236                       
     237
     238      (let* ((new-point (#/cascadeTopLeftFromPoint: window current-point)))
     239        (setf *next-listener-x-pos* (ns:ns-point-x new-point)
     240              *next-listener-y-pos* (ns:ns-point-y new-point))))
    243241    (setf (hi::buffer-process (hemlock-document-buffer self))
    244242          (let* ((tty (slot-value controller 'clientfd))
    245                  (peer-tty (send (slot-value controller 'filehandle)
    246                                  'file-descriptor)))
     243                 (peer-tty (#/fileDescriptor (slot-value controller 'filehandle))))
    247244            (new-cocoa-listener-process listener-name tty tty peer-tty)))
    248245    controller))
    249246
    250247;;; Action methods
    251 (define-objc-method ((:void :interrupt sender) hemlock-listener-document)
     248(objd:defmethod (#/interrupt: :void) ((self hemlock-listener-document) sender)
    252249  (declare (ignore sender))
    253250  (let* ((buffer (hemlock-document-buffer self))
     
    259256  (car (cocoa-listener-process-backtrace-contexts proc)))
    260257
    261 (define-objc-method ((:void :backtrace sender) hemlock-listener-document)
     258(objc:defmethod (#/backtrace: :void) ((self hemlock-listener-document) sender)
    262259  (declare (ignore sender))
    263260  (let* ((buffer (hemlock-document-buffer self))
     
    266263      (let* ((context (listener-backtrace-context process)))
    267264        (when context
    268           (send (backtrace-controller-for-context context)
    269                 :show-window (%null-ptr)))))))
     265          (#/showWindow: (backtrace-controller-for-context context) (%null-ptr)))))))
    270266
    271267;;; Menu item action validation.  It'd be nice if we could distribute this a
     
    280276         (process (if buffer (hi::buffer-process buffer))))
    281277    (if (typep process 'cocoa-listener-process)
    282       (let* ((action (send item 'action)))
     278      (let* ((action (#/action item)))
    283279        (cond
    284           ((eql action (@selector "interrupt:")) (values t t))
    285           ((eql action (@selector "backtrace:"))
     280          ((eql action (@selector #/interrupt:)) (values t t))
     281          ((eql action (@selector #/backtrace:))
    286282           (values t
    287283                   (not (null (listener-backtrace-context process)))))))
    288284      (values nil nil))))
    289285
    290 (define-objc-method ((:<BOOL> :validate-menu-item item)
    291                      hemlock-listener-document)
     286(objc:defmethod (#/validateMenuItem :<BOOL>)
     287    ((self hemlock-listener-document) item)
    292288  (multiple-value-bind (have-opinion opinion)
    293289      (document-validate-menu-item self item)
    294290    (if have-opinion
    295291      opinion
    296       (send-super :validate-menu-item item))))
     292      (call-next-method item))))
    297293
    298294(defun shortest-package-name (package)
     
    329325                                                    selection)
    330326  (declare (ignore selection))
    331   (let* ((top-listener-document (send (find-class 'hemlock-listener-document)
    332                                       'top-listener)))
     327  (let* ((top-listener-document (#/topListener hemlock-listener-document)
    333328    (if top-listener-document
    334329      (let* ((buffer (hemlock-document-buffer top-listener-document)))
  • branches/objc-gf/ccl/examples/cocoa-prefs.lisp

    r5885 r6112  
    9898    (send form 'size-to-cells)))
    9999
    100 (define-objc-method ((:void :note-prefs-change form) prefs-view)
    101   (let* ((cell (send form :cell-at-index (send form 'index-of-selected-item)))
     100(objc:defmethod (#/notePrefsChange: :void) ((self prefs-view) form)
     101  (let* ((cell (#/cellAtIndex: form (#/indexOfSelectedItem form)))
    102102         (n (prefs-view-nvalues self))
    103103         (form (prefs-view-form self))
    104          (current (send cell 'tag))
     104         (current (#/tag  cell))
    105105         (d (svref (prefs-view-defaults-vector self) current))
    106106         (next (mod (1+ current) n))
    107          (value (send cell 'string-value)))
    108     (unless (send value
    109                   :is-equal-to
    110                   (send (prefs-view-domain self)
    111                         :object-for-key
    112                         (objc-constant-string-nsstringptr (cocoa-default-string d))))
     107         (value (#/stringValue cell)))
     108    (unless (#/isEqualTo: value
     109                          (#/objectForKey (prefs-view-domain self)
     110                                          (objc-constant-string-nsstringptr (cocoa-default-string d))))
    113111      ;; If there's a constraint, sanity-check the value.
    114112      (when (zerop (prefs-view-nchanges self))
    115         (send (prefs-view-commit-button self) :set-enabled t)
    116         (send (prefs-view-revert-button self) :set-enabled t))
     113        (#/setEnabled: (prefs-view-commit-button self) t)
     114        (#/setEnabled  (prefs-view-revert-button self) t))
    117115      (incf (prefs-view-nchanges self)))
    118     (send form :select-cell (send form :cell-at-index next))))
    119 
    120 (define-objc-method ((:void :commit-prefs sender) prefs-view)
     116    (#/selectCell: form (#/cellAtIndex: form next))))
     117
     118(objc:defmethod (#/commitPrefs: :void) ((self prefs-view) sender)
    121119  (declare (ignore sender))
    122120  (let* ((form (prefs-view-form self))
    123121         (domain (prefs-view-domain self)))
    124122    (dotimes (i (prefs-view-nvalues self))
    125       (let* ((cell (send form :cell-at-index i))
    126              (key (send cell 'title))
    127              (val (send cell 'string-value)))
    128         (send domain :set-object val :for-key key)))
    129     (send domain 'synchronize)
     123      (let* ((cell (#/cellAtIndex: form i))
     124             (key (#/title  cell))
     125             (val (#/stringValue  cell)))
     126        (#/setObject:forKey: domain val key)))
     127    (#/synchronize domain)
    130128    (setf (prefs-view-nchanges self) 0)
    131     (send (prefs-view-revert-button self) :set-enabled nil)
    132     (send (prefs-view-commit-button self) :set-enabled nil)
     129    (#/setEnabled: (prefs-view-revert-button self) nil)
     130    (#/setEnabled: (prefs-view-commit-button self) nil)
    133131    (update-cocoa-defaults-vector domain (prefs-view-defaults-vector self))))
    134132
    135 (define-objc-method ((:void :revert-prefs sender) prefs-view)
     133(objc:defmethod (#/revertPrefs: :void) ((self prefs-view) sender)
    136134  (declare (ignore sender))
    137135  (let* ((form (prefs-view-form self))
    138136         (domain (prefs-view-domain self)))
    139137    (dotimes (i (prefs-view-nvalues self))
    140       (let* ((cell (send form :cell-at-index i))
    141              (key (send cell 'title)))
    142         (send cell :set-string-value (send domain :object-for-key key))))
     138      (let* ((cell (#/cellAtIndex: form i))
     139             (key (#/title cell)))
     140        (#/setStringValue: cell (#/objectForKey: domain key))))
    143141    (setf (prefs-view-nchanges self) 0)
    144     (send (prefs-view-revert-button self) :set-enabled nil)
    145     (send (prefs-view-commit-button self) :set-enabled nil)))
     142    (#/setEnabled: (prefs-view-revert-button self) nil)
     143    (#/setEnabled: (prefs-view-commit-button self) nil)))
    146144
    147145 
     
    206204  (:metaclass ns:+ns-object))
    207205
    208 (define-objc-class-method ((:id shared-panel) preferences-panel)
     206(objc:defmethod #/sharedPanel ((self +preferences-panel))
    209207  (cond (*preferences-panel*)
    210208        (t
     
    212210                                         :title "Preferences"
    213211                                         :activate nil))
    214                 (view (send panel 'content-view)))
    215            (slet ((bounds (send view 'bounds)))
    216              (let* ((v (make-instance 'prefs-view :with-frame bounds)))
    217                (send panel :set-content-view v)
    218                (send v :set-needs-display t)
    219                (setf (slot-value panel 'prefs-view) v)
    220                (setq *preferences-panel* panel)))))))
    221 
    222 (define-objc-method ((:id init) preferences-panel)
     212                (view (#/contentView panel))
     213                (bounds (#/bounds view))
     214                (v (make-instance 'prefs-view :with-frame bounds)))
     215           (#/setContentView: panel v)
     216           (#/setNeedsDisplay: v t)
     217           (setf (slot-value panel 'prefs-view) v)
     218           (setq *preferences-panel* panel)))))
     219
     220(objc:defmethod #/init ((self preferences-panel))
    223221  (let* ((class (class-of self)))
    224     (send self 'dealloc)
     222    (#/dealloc self)
    225223    (send class 'shared-panel)))
    226224
    227 (define-objc-method ((:void show) preferences-panel)
     225(objc:defmethod (#/show :void) ((self preferences-panel))
    228226  (init-prefs-form-from-defaults (preferences-panel-prefs-view self))
    229   (send self :make-key-and-order-front (%null-ptr)))
     227  (#/makeKeyAndOrderFront: self (%null-ptr)))
  • branches/objc-gf/ccl/examples/cocoa-window.lisp

    r5911 r6112  
    3838  (with-autorelease-pool
    3939      (let* ((bundle (open-main-bundle))
    40              (dict (send bundle 'info-dictionary))
    41              (classname (send dict :object-for-key #@"NSPrincipalClass"))
    42              (mainnibname (send dict :object-for-key  #@"NSMainNibFile"))
    43              (progname (send dict :object-for-key #@"CFBundleName")))
     40             (dict (#/infoDictionary  bundle))
     41             (classname (#/objectForKey dict #@"NSPrincipalClass"))
     42             (mainnibname (#/objectForKey: dict  #@"NSMainNibFile"))
     43             (progname (#/objectForKey: dict #@"CFBundleName")))
    4444        (if (%null-ptr-p classname)
    4545          (error "problems loading bundle: can't determine class name"))
     
    4747          (error "problems loading bundle: can't determine main nib name"))
    4848        (unless (%null-ptr-p progname)
    49           (send (send (@class ns-process-info) 'process-info)
    50                 :set-process-name progname))
     49          (#/setProcessName (#/processInfo ns:ns-process-info)))
    5150        (let* ((appclass (#_NSClassFromString classname))
    52                (app (send appclass 'shared-application)))
    53           (send (@class ns-bundle)
    54                 :load-nib-named mainnibname
    55                 :owner app)
     51               (app (#/sharedApplication appclass)))
     52          (#/loadNibNamed:owner: ns:ns-bundle mainnibname  app)
    5653          app))))
    5754
     
    8279
    8380
    84 (define-objc-method ((:void :post-event-at-start e) ns:ns-application)
    85   (send self :post-event e :at-start t))
     81(objc:defmethod (#/postEventAtStart: :void) ((self  ns:ns-application) e)
     82  (#/postEvent:atStart: self e t))
    8683
    8784;;; Interrupt the AppKit event process, by enqueing an event (if the
     
    9592  (if (eq process *current-process*)
    9693    (apply function args)
    97     (if (or (not *NSApp*) (not (send *NSApp* 'is-running)))
     94    (if (or (not *NSApp*) (not (#/isRunning *NSApp*)))
    9895      (call-next-method)
    99       (let* ((e (send (@class ns-event)
    100                       :other-event-with-type #$NSApplicationDefined
    101                       :location (ns-make-point +cgfloat-zero+ +cgfloat-zero+)
    102                       :modifier-flags 0
    103                       :timestamp 0.0d0
    104                       :window-number 0
    105                       :context (%null-ptr)
    106                       :subtype process-interrupt-event-subtype
    107                       :data1 (register-appkit-process-interrupt
    108                               #'(lambda () (apply function args)))
    109                       :data2 0)))
    110         (send e 'retain)
    111         (send *NSApp*
    112               :perform-selector-on-main-thread (@selector
    113                                                 "postEventAtStart:")
    114               :with-object e
    115               :wait-until-done t)))))
    116 
    117 
     96      (rletZ ((point :ns-point))
     97        (let* ((e (#/otherEventWithType:location:modifierFlags:timestamp:windowNumber:context:subtype:data1:data2:
     98                   ns:ns-event
     99                   #$NSApplicationDefined
     100                   point
     101                   0
     102                   0.0d0
     103                   0
     104                   (%null-ptr)
     105                   process-interrupt-event-subtype
     106                   (register-appkit-process-interrupt
     107                    #'(lambda () (apply function args))) 0)))
     108        (#/retain e)
     109        (#/performSelectorOnMainThread:withObject:waitUntilDone:
     110         *NSApp* (@selector "postEventAtStart:") e  t))))))
    118111
    119112
     
    130123;;; I'm not sure if there's another way to recognize events whose
    131124;;; type is #$NSApplicationDefined.
    132 (define-objc-method ((:void :send-event e)
    133                      lisp-application)
    134   (if (and (eql (send (the ns:ns-event e) 'type) #$NSApplicationDefined)
    135            (eql (send (the ns:ns-event e) 'subtype) process-interrupt-event-subtype))
     125(objc:defmethod (#/sendEvent: :void) ((self lisp-application) e)
     126  (if (and (eql (#/type e #$NSApplicationDefined)
     127           (eql (#/subtype e  process-interrupt-event-subtype))
    136128    ;;; The thunk to funcall is identified by the value
    137129    ;;; of the event's data1 attribute.
    138     (funcall (appkit-interrupt-function (send e 'data1)))
    139     (send-super :send-event e)))
    140 
    141 
    142 
    143 (define-objc-method ((:void :show-preferences sender) lisp-application)
     130    (funcall (appkit-interrupt-function (#/data1 e)))
     131    (call-next-method e)))
     132
     133
     134(objc:defmethod (#/showPreferences: :void) ((self lisp-application) sender)
    144135  (declare (ignore sender))
    145   (send (send (find-class 'preferences-panel) 'shared-panel) 'show))
    146 
    147 (define-objc-method ((:void :toggle-typeout sender) lisp-application)
     136  (#/show (#/sharedPanel preferenes-panel)))
     137
     138(objc:defmethod (#/toggleTypeout: :void) ((self lisp-application) sender)
    148139  (declare (ignore sender))
    149   (let ((panel (send (find-class 'typeout-panel) 'shared-panel)))
    150     (send panel 'show)))
     140  (#/show (#/sharedPanel typeout-panel)))
    151141
    152142(defun nslog-condition (c)
     
    157147
    158148
    159 
    160 
    161149(defmethod process-exit-application ((process appkit-process) thunk)
    162150  (when (eq process *initial-process*)
    163151    (%set-toplevel thunk)
    164     (send (the lisp-application *NSApp*) :terminate (%null-ptr))
    165     ))
     152    (#/terminate: *NSApp* (%null-ptr))))
    166153
    167154(defun run-event-loop ()
     
    170157  (let* ((app *NSApp*))
    171158    (loop
    172         (handler-case (send (the ns-application app) 'run)
     159        (handler-case (#/run app)
    173160          (error (c) (nslog-condition c)))
    174         (unless (send app 'is-running)
     161        (unless (#/isRunning app)
    175162          (return)))))
    176163
     
    183170  (flet ((cocoa-startup ()
    184171           ;; Start up a thread to run periodic tasks.
    185            ;; Under Linux/GNUstep, some of these might have to run in
    186            ;; the main thread (because of PID/thread conflation.)
    187172           (process-run-function "housekeeping"
    188173                                 #'(lambda ()
     
    195180             (enable-foreground)
    196181             (or *NSApp* (setq *NSApp* (init-cocoa-application)))
    197              (let* ((icon (send (@class ns-image) :image-named #@"NSApplicationIcon")))
     182             (let* ((icon (#/imageNamed: ns:ns-image #@"NSApplicationIcon")))
    198183               (unless (%null-ptr-p icon)
    199                  (send *NSApp* :set-application-icon-image icon)))
     184                 (#/setApplicationIconImage *NSApp* icon)))
    200185             (setf (application-ui-object *application*) *NSApp*)
    201186             (when application-proxy-class-name
    202187               (let* ((classptr (%objc-class-classptr
    203188                                 (load-objc-class-descriptor application-proxy-class-name)))
    204                       (instance (send (send classptr 'alloc) 'init)))
    205 
    206                  (send *NSApp* :set-delegate instance))))
     189                      (instance (#/init (#/alloc classptr))))
     190
     191                 (#/setDelegate: *NSApp* instance))))
    207192           (run-event-loop)))
    208193    (process-interrupt *cocoa-event-process* #'(lambda ()
     
    215200    (:italic . #.#$NSItalicFontMask)
    216201    (:small-caps . #.#$NSSmallCapsFontMask)))
    217    
     202
     203
     204;;; The NSFont method #/isFixedPitch has returned random answers
     205;;; in many cases for the last few OSX releases.  Try to return
     206;;; a reasonable answer, by checking to see if the width of the
     207;;; advancement for the #\i glyph matches that of the advancement
     208;;; of the #\m glyph.
     209
     210(defun is-fixed-pitch-font (font)
     211  (= (ns:ns-size-width (#/advancementForGlyph: font (#/glyphWithName: font #@"i")))
     212     (ns:ns-size-width (#/advancementForGlyph: font (#/glyphWithName: font #@"m")))))
     213
    218214;;; Try to find the specified font.  If it doesn't exist (or isn't
    219215;;; fixed-pitch), try to find a fixed-pitch font of the indicated size.
     
    228224          (setf (paref matrix (:* :<CGF>loat) 0) size
    229225                (paref matrix (:* :<CGF>loat) 3) size)
    230           (let* ((fontname (send (@class ns-string) :string-with-c-string name))
    231                  (font (send (@class ns-font)
    232                               :font-with-name fontname :matrix matrix))
     226          (let* ((fontname (#/stringWithCString: ns:ns-string name))
     227                 (font (#/fontWithName:matrix: ns:ns-font fontname matrix))
    233228                   
    234229                 (implemented-attributes ()))
    235230            (if (or (%null-ptr-p font)
    236231                    (and
    237                      (not (send font 'is-fixed-pitch))
    238                      (not (eql #$YES (objc-message-send font "_isFakeFixedPitch" :<BOOL>)))))
    239               (setq font (send (@class ns-font)
    240                                :user-fixed-pitch-font-of-size size)))
     232                     (not (is-fixed-pitch-font font))))
     233              (setq font (#/userFixedPitchFontOfSize: ns:ns-font size)))
    241234            (when attributes
    242235              (dolist (attr-name attributes)
     
    245238                  (when pair
    246239                    (setq newfont
    247                           (send
    248                            (send (@class "NSFontManager") 'shared-font-manager)
    249                            :convert-font font
    250                            :to-have-trait (cdr pair)))
     240                          (#/convertFont:toHaveTrait:
     241                           (#/sharedFontManager ns:ns-font-manager) font (cdr pair)))
    251242                    (unless (eql font newfont)
    252243                      (setq font newfont)
    253244                      (push attr-name implemented-attributes))))))
    254             (values (send font 'retain) implemented-attributes))))))
     245            (values (#/retain font) implemented-attributes))))))
    255246
    256247;;; Create a paragraph style, mostly so that we can set tabs reasonably.
    257248(defun create-paragraph-style (font line-break-mode)
    258249  (let* ((p (make-objc-instance 'ns-mutable-paragraph-style))
    259          (charwidth (slet ((advance
    260                             (send font 'maximum-advancement)))
    261                       (fround (pref advance :<NSS>ize.width)))))
    262     (send p
    263           :set-line-break-mode
    264           (ecase line-break-mode
    265             (:char #$NSLineBreakByCharWrapping)
    266             (:word #$NSLineBreakByWordWrapping)
    267             ;; This doesn't seem to work too well.
    268             ((nil) #$NSLineBreakByClipping)))
     250         (charwidth (fround (ns:ns-size-width (#/maximumAdvancement font)))))
     251    (#/setLineBreakMode: p
     252                         (ecase line-break-mode
     253                           (:char #$NSLineBreakByCharWrapping)
     254                           (:word #$NSLineBreakByWordWrapping)
     255                           ;; This doesn't seem to work too well.
     256                           ((nil) #$NSLineBreakByClipping)))
    269257    ;; Clear existing tab stops.
    270     (send p :set-tab-stops (send (@class ns-array) 'array))
     258    (#/setTabStops: p (#/array ns:ns-array))
    271259    (do* ((i 1 (1+ i)))
    272260         ((= i 100) p)
     
    276264                       :location  (* (* i *tab-width*)
    277265                                        charwidth))))
    278         (send p :add-tab-stop tabstop)
    279         (send tabstop 'release)))))
     266        (#/addTabStop: p tabstop)
     267        (#/release tabstop)))))
    280268   
    281269(defun create-text-attributes (&key (font (default-font))
     
    287275                'ns-mutable-dictionary
    288276                :with-capacity 5)))
    289     (send dict 'retain)
    290     (send dict
    291           :set-object (create-paragraph-style font line-break-mode)
    292           :for-key #&NSParagraphStyleAttributeName)
    293     (send dict :set-object font :for-key #&NSFontAttributeName)
     277    (#/retain dict)
     278    (#/setObject:forKey: dict (create-paragraph-style font line-break-mode) #&NSParagraphStyleAttributeName)
     279    (#/setObject:forKey: dict font #&NSFontAttributeName)
    294280    (when color
    295       (send dict :set-object color :for-key #&NSForegroundColorAttributeName))
     281      (#/setObject:forKey: dict color #&NSForegroundColorAttributeName))
    296282    (when stroke-width
    297       (send dict :set-object (make-objc-instance 'ns:ns-number
    298                                                 :with-float (float stroke-width))
    299             :for-key #&NSStrokeWidthAttributeName))
     283      (#/setObject:forKey: dict (make-objc-instance 'ns:ns-number
     284                                                    :with-float (float stroke-width)) #&NSStrokeWidthAttributeName))
    300285    (when obliqueness
    301       (send dict :set-object (make-objc-instance 'ns:ns-number
    302                                                 :with-float (float obliqueness))
    303             :for-key #&NSObliquenessAttributeName))
     286      (#/setObject:forKey:  dict (make-objc-instance 'ns:ns-number
     287                                                     :with-float (float obliqueness)) #&NSObliquenessAttributeName))
    304288    dict))
    305289
     
    308292  (case flagname
    309293    (:accepts-mouse-moved-events
    310      (send w 'accepts-mouse-moved-events))
     294     (#/acceptsMouseMovedEvents w))
    311295    (:cursor-rects-enabled
    312      (send w 'are-cursor-rects-enabled))
     296     (#/areCursorRectsEnabled w))
    313297    (:auto-display
    314      (send w 'is-autodisplay))))
     298     (#/isAutodisplay w))))
    315299
    316300
     
    319303  (case flagname
    320304    (:accepts-mouse-moved-events
    321      (send w :set-accepts-mouse-moved-events value))
     305     (#/setAcceptsMouseMovedEvents: w value))
    322306    (:auto-display
    323      (send w :set-autodisplay value))))
     307     (#/setAutodisplay: w value))))
    324308
    325309
     
    327311(defun activate-window (w)
    328312  ;; Make w the "key" and frontmost window.  Make it visible, if need be.
    329   (send w :make-key-and-order-front nil))
     313  (#/makeKeyAndOrderFront: w nil))
    330314
    331315(defun new-cocoa-window (&key
     
    345329                         (auto-display t)
    346330                         (activate t))
    347   (rlet ((frame :<NSR>ect
    348            :origin.x (float x +cgfloat-zero+)
    349            :origin.y (float y +cgfloat-zero+)
    350            :size.width (float width +cgfloat-zero+)
    351            :size.height (float height +cgfloat-zero+)))
     331  (rlet ((frame :ns-rect))
     332    (ns:init-ns-rect frame x y width height)
    352333    (let* ((stylemask
    353334            (logior #$NSTitledWindowMask
     
    372353            auto-display)
    373354      (when activate (activate-window w))
    374       (when title (send w :set-title (%make-nsstring title)))
     355      (when title (#/setTitle: w (%make-nsstring title)))
    375356      w)))
    376357
  • branches/objc-gf/ccl/examples/cocoa.lisp

    r5695 r6112  
    2626
    2727
    28 (define-objc-method ((:void :application-will-finish-launching (:id notification))
    29                      lisp-application-delegate)
     28(objc:defmethod (#/applicationWillFinishLaunching: :void)
     29    ((self lisp-application-delegate) notification)
    3030  (declare (ignore notification))
    3131  (initialize-user-interface))
    3232
    33 (define-objc-method ((:void :application-will-terminate (:id notification))
    34                      lisp-application-delegate)
     33(objc:defmethod (#/applicationWillTerminate: :void)
     34    ((self lisp-application-delegate) notification)
    3535  (declare (ignore notification))
    3636  ;; UI has decided to quit; terminate other lisp threads.
    3737  (prepare-to-quit))
    3838
    39 (define-objc-method ((:void :new-listener sender) lisp-application-delegate)
    40   (declare (ignore sender))
    41   (send (send (@class ns-document-controller) 'shared-document-controller)
    42         :open-untitled-document-of-type #@"Listener" :display t))
     39(objc:defmethod (#/newListener: :void) ((self lisp-application-delegate)
     40                                        sender)
     41  (#/openUntitledDocumentOfType:display:
     42   (#/sharedDocumentController ns:ns-document-controller)
     43   #@"Listener"
     44   t))
    4345
    4446(defvar *cocoa-application-finished-launching* (make-semaphore)
    4547  "Semaphore that's signaled when the application's finished launching ...")
    4648
    47 (define-objc-method ((:void :application-did-finish-launching notification)
    48                      lisp-application-delegate)
     49(objc:defmethod (#/applicationDidFinishLaunching: :void)
     50    ((self lisp-application-delegate) notification)
    4951  (declare (ignore notification))
    5052  (signal-semaphore *cocoa-application-finished-launching*))
    5153
    52 
    53 (define-objc-method ((:<BOOL> :application-open-untitled-file app)
    54                      lisp-application-delegate)
     54(objc:defmethod (#/applicationOpenUntitledFile: :<BOOL>)
     55    ((self lisp-application-delegate app))
    5556  (when (zerop *cocoa-listener-count*)
    56     (send self :new-listener app)
     57    (#/newListener: self app)
    5758    t))
    5859
     
    8889(start-cocoa-application)
    8990
     91
  • branches/objc-gf/ccl/examples/objc-package.lisp

    r6074 r6112  
    2828(defpackage "OBJC"
    2929  (:use)
    30   (:export "OBJC-OBJECT" "OBJC-CLASS-OBJECT" "OBJC-CLASS" "OBJC-METACLASS"))
     30  (:export "OBJC-OBJECT" "OBJC-CLASS-OBJECT" "OBJC-CLASS" "OBJC-METACLASS"
     31           "DEFMETHOD"))
    3132
    3233
  • branches/objc-gf/ccl/examples/objc-runtime.lisp

    r6106 r6112  
    721721                           "NS"))
    722722                         (meta-super
    723                           (if super (pref super :objc_class.isa))))
     723                          (if super (pref super #+apple-objc :objc_class.isa
     724                                          #+gnu-objc :objc_class.class_pointer))))
    724725                    ;; It's important (here and when initializing the
    725726                    ;; class below) to use the "canonical"
     
    12591260  (funcall (ftd-ff-call-expand-function *target-ftd*)
    12601261           `(%ff-call (%reference-external-entry-point (load-time-value (external "_objc_msgSendSuper"))))
    1261            `(:address ,super :<SEL> (%get-selector ,selector) ,@argspecs)
     1262           `(:address ,super :<SEL> ,selector ,@argspecs)
    12621263           :arg-coerce 'objc-arg-coerce
    12631264           :result-coerce 'objc-result-coerce)
     
    12671268         (imp (gensym)))
    12681269    `(with-macptrs ((,sup ,super)
    1269                     (,sel (%get-selector ,selector))
     1270                    (,sel ,selector)
    12701271                    (,imp (external-call "objc_msg_lookup_super"
    12711272                                         :<S>uper_t ,sup
     
    19251926  (#_objc_registerClassPair class))
    19261927
    1927 (defun %make-nsstring (string)
    1928   (with-cstrs ((s string))
    1929     (objc-message-send
    1930      (objc-message-send (find-class 'ns:ns-string) "alloc")
    1931      "initWithCString:" :address s)))
     1928
     1929
     1930
     1931
    19321932
    19331933
     
    23342334                                (pref (@class ,class-name)
    23352335                                 #+apple-objc :objc_class.isa
    2336                                  #+gnu-objc :objc_class.super_class )
     2336                                 #+gnu-objc :objc_class.class_pointer)
    23372337                                :objc_class.super_class))
    23382338                             #+apple-objc-2.0
     
    23622362  (objc-method-definition-form t selector-arg class-arg body env))
    23632363
     2364
     2365
     2366
     2367
     2368(defmacro objc:defmethod (name (self-arg &rest other-args) &body body &environment env)
     2369  (collect ((arglist)
     2370            (arg-names)
     2371            (arg-types)
     2372            (bool-args))
     2373    (let* ((result-type nil)
     2374           (selector nil)
     2375           (cmd (intern "_CMD"))
     2376           (class-p nil)
     2377           (objc-class-name nil))
     2378      (if (atom name)
     2379        (setq selector (string name) result-type :id)
     2380        (setq selector (string (car name)) result-type (concise-foreign-type (or (cadr name) :id))))
     2381      (destructuring-bind (self-name lisp-class-name) self-arg
     2382        (arg-names self-name)
     2383        (arg-types :id)
     2384        ;; Hack-o-rama
     2385        (let* ((lisp-class-name (string lisp-class-name)))
     2386          (if (eq (schar lisp-class-name 0) #\+)
     2387            (setq class-p t lisp-class-name (subseq lisp-class-name 1)))
     2388          (setq objc-class-name (lisp-to-objc-classname lisp-class-name)))
     2389        (arg-types :<SEL>)
     2390        (arg-names cmd)
     2391        (dolist (arg other-args)
     2392          (if (atom arg)
     2393            (progn
     2394              (arg-types :id)
     2395              (arg-names arg))
     2396            (destructuring-bind (arg-name arg-type) arg
     2397              (arg-types (concise-foreign-type arg-type))
     2398              (arg-names arg-name))))
     2399        (let* ((arg-names (arg-names))
     2400               (arg-types (arg-types)))
     2401          (do* ((names arg-names)
     2402                (types arg-types))
     2403               ((null types) (arglist result-type))
     2404            (let* ((name (pop names))
     2405                   (type (pop types)))
     2406              (arglist type)
     2407              (arglist name)
     2408              (if (eq type :<BOOL>)
     2409                (bool-args `(setq ,name (not (eql ,name 0)))))))
     2410          (let* ((impname (intern (format nil "~c[~a ~a]"
     2411                                          (if class-p #\+ #\-)
     2412                                          objc-class-name
     2413                                          selector)))
     2414                 (typestring (encode-objc-method-arglist arg-types result-type))
     2415                 (signature
     2416                  (%declare-objc-method selector
     2417                                        objc-class-name
     2418                                        class-p
     2419                                        result-type
     2420                                        (cddr arg-types))))
     2421            (multiple-value-bind (body decls) (parse-body body env)
     2422             
     2423              (setq body `((progn ,@(bool-args) ,@body)))
     2424              (if (eq result-type :<BOOL>)
     2425                (setq body `((%coerce-to-bool ,@body))))
     2426              (setq body `((flet ((call-next-method (&rest args)
     2427                                  (declare (dynamic-extent args))
     2428                                  (apply (function ,(if class-p
     2429                                                        '%call-next-objc-class-method
     2430                                                        '%call-next-objc-method))
     2431                                         ,self-name
     2432                                         (@class ,objc-class-name)
     2433                                         (@selector ,selector)
     2434                                         ',signature
     2435                                         args)))
     2436                                 (declare (inline call-next-method))
     2437                                 ,@body)))
     2438              `(progn
     2439                (defcallback ,impname ( :error-return (condition objc-callback-error-return) ,@(arglist))
     2440                  (declare (ignorable ,self-name ,cmd)
     2441                           (unsettable ,self-name))
     2442                  ,@decls
     2443                  ,@body)
     2444                (%define-lisp-objc-method
     2445                 ',impname
     2446                 ,objc-class-name
     2447                 ,selector
     2448                 ,typestring
     2449                 ,impname
     2450                 ,class-p)))))))))
     2451
     2452     
     2453           
     2454 
     2455
    23642456(defun class-get-instance-method (class sel)
    23652457  #+apple-objc (#_class_getInstanceMethod class sel)
     
    24072499
    24082500
    2409 (defun retain-objc-instance (instance)
    2410   (objc-message-send instance "retain"))
    2411 
    24122501;;; Execute BODY with an autorelease pool
    2413 
    2414 (defun create-autorelease-pool ()
    2415   (objc-message-send
    2416    (objc-message-send (@class "NSAutoreleasePool") "alloc") "init"))
    2417 
    2418 (defun release-autorelease-pool (p)
    2419   (objc-message-send p "release"))
    24202502
    24212503(defmacro with-autorelease-pool (&body body)
     
    24262508        (release-autorelease-pool ,pool-temp)))))
    24272509
    2428 ;;; This can fail if the nsstring contains non-8-bit characters.
    2429 (defun lisp-string-from-nsstring (nsstring)
    2430   (with-macptrs (cstring)
    2431     (%setf-macptr cstring (objc-message-send nsstring "cString" (* :char)))
    2432     (unless (%null-ptr-p cstring)
    2433       (%get-cstring cstring))))
     2510(defun %make-nsstring (string)
     2511  (with-cstrs ((s string))
     2512    (%make-nsstring-from-c-string s)))
    24342513
    24352514#+apple-objc-2.0
  • branches/objc-gf/ccl/examples/objc-support.lisp

    r6058 r6112  
    77
    88(defun allocate-objc-object (class)
    9   (send class 'alloc))
     9  (#/alloc class))
    1010
    1111(defun conforms-to-protocol (thing protocol)
    12   (objc-message-send thing "conformsToProtocol:" :address (objc-protocol-address protocol) :<BOOL>))
     12  (#/conformsToProtocol: thing (objc-protocol-address protocol)))
    1313
    1414
     
    127127  (:metaclass ns::+ns-object))
    128128
    129 (define-objc-method ((:id init)
    130                      ns-lisp-exception)
    131   (send self
    132         :init-with-name #@"lisp exception"
    133         :reason #@"lisp exception"
    134         :user-info (%null-ptr)))
    135 
    136 
    137 (define-objc-method ((:id reason) ns-lisp-exception)
     129(objc:defmethod #/init ((self ns-lisp-exception))
     130  (#/initWithName:reason:userInfo: self #@"lisp exception" #@"lisp exception" (%null-ptr)))
     131
     132
     133(defun %make-nsstring-from-c-string (s)
     134  (#/initWithCString: (#/alloc ns:ns-string) s))
     135
     136(defun retain-objc-instance (instance)
     137  (#/retain instance))
     138
     139
     140(defun create-autorelease-pool ()
     141  (#/init (#/alloc ns:ns-autorelease-pool)))
     142
     143(defun release-autorelease-pool (p)
     144  (#/release p))
     145
     146;;; This can fail if the nsstring contains non-8-bit characters.
     147(defun lisp-string-from-nsstring (nsstring)
     148  (with-macptrs (cstring)
     149    (%setf-macptr cstring
     150                  (#/cStringUsingEncoding: nsstring #$NSASCIIStringEncoding))
     151    (unless (%null-ptr-p cstring)
     152      (%get-cstring cstring))))
     153
     154
     155(objc:defmethod #/reason ((self ns-lisp-exception))
    138156  (with-slots (condition) self
    139157    (if condition
    140158      (%make-nsstring (format nil "~A" condition))
    141       (send-super 'reason))))
    142    
    143 (define-objc-method ((:id description) ns-lisp-exception)
    144   (send (find-class 'ns:ns-string)
    145         :string-with-format #@"Lisp exception: %@"
    146         (:id (send self 'reason))))
    147 
    148 
    149        
    150              
     159      (call-next-method))))
     160
     161(objc:defmethod #/description ((self ns-lisp-exception))
     162  (#/stringWithFormat: ns:ns-string #@"Lisp exception: %@" (#/reason self)))
     163
     164
    151165                     
    152166(defun ns-exception->lisp-condition (nsexception)
     
    162176  ;;; Create an NSLispException with a lispid that encapsulates
    163177  ;;; this condition.
    164   ;;;
    165 
    166178
    167179  #|(dbg (format nil "~a" c))|#
    168180  ;;(#_NSLog #@"Lisp exception: %@" :id (%make-nsstring (format nil "~a" c)))
    169181  (make-instance 'ns-lisp-exception :condition c))
    170  
    171 
    172182
    173183
     
    240250
    241251(defun open-main-bundle ()
    242   (send (@class ns-bundle) 'main-bundle))
     252  (#/mainBundle ns:ns-bundle))
    243253
    244254;;; Create a new immutable dictionary just like src, replacing the
     
    247257  (declare (dynamic-extent key-value-pairs))
    248258  ;(#_NSLog #@"src = %@" :id src)
    249   (let* ((count (send src 'count))
    250          (enum (send src 'key-enumerator))
    251          (keys (send (@class "NSMutableArray") :array-with-capacity count))
    252          (values (send (@class "NSMutableArray") :array-with-capacity count)))
     259  (let* ((count (#/count src))
     260         (enum (#/keyEnumerator src))
     261         (keys (#/arrayWithCapacity: ns:ns-mutable-array count))
     262         (values (#/arrayWithCapacity: ns:ns-mutable-array count)))
    253263    (loop
    254         (let* ((nextkey (send enum 'next-object)))
     264        (let* ((nextkey (#/nextObject enum)))
    255265          (when (%null-ptr-p nextkey)
    256266            (return))
     
    260270               ((null kvps)
    261271                ;; Copy the key, value pair from the src dict
    262                 (send keys :add-object nextkey)
    263                 (send values :add-object (send src :object-for-key nextkey)))
    264             (when (send nextkey :is-equal-to-string newkey)
    265               (send keys :add-object nextkey)
    266               (send values :add-object newval)
     272                (#/addObject: keys nextkey)
     273                (#/addObject: values (#/objectForKey: src nextkey)))
     274            (when (#/isEqualToString: nextkey newkey)
     275              (#/addObject: keys nextkey)
     276              (#/addObject: values newval)
    267277              (return)))))
    268278    (make-objc-instance 'ns-dictionary
     
    275285NSObjects describe themselves in more detail than others."
    276286  (with-autorelease-pool
    277       (lisp-string-from-nsstring  (send nsobject 'description))))
     287      (lisp-string-from-nsstring  (#/description nsobject))))
    278288
    279289
     
    384394              (with-nsstr (nsnamestring cnamestring (length namestring))
    385395                (with-autorelease-pool
    386                     (let* ((bundle (send (find-class 'ns:ns-bundle)
    387                                          :bundle-with-path nsnamestring))
     396                    (let* ((bundle (#/bundleWithPath: 'ns:ns-bundle nsnamestring))
    388397                           (winning (unless (%null-ptr-p bundle)
    389                                       (or t
    390                                           (send (the ns:ns-bundle bundle) 'load)))))
     398                                      t)))
    391399                      (when winning
    392                         (let* ((libpath (send bundle 'executable-path)))
     400                        (let* ((libpath (#/executablePath bundle)))
    393401                          (unless (%null-ptr-p libpath)
    394402                            (open-shared-library (lisp-string-from-nsstring
    395403                                                  libpath))))
    396                         (send (the ns:ns-bundle bundle) 'load)
     404                        (#/load bundle)
    397405                        (pushnew path *extension-framework-paths*
    398406                                 :test #'equalp)
     
    406414  (print-unreadable-object (p stream :type t)
    407415    (format stream "~a (#x~x)"
    408             (%get-cstring (send p 'name))
     416            (%get-cstring (#/name p))
    409417            (%ptr-to-int p))))
    410418
  • branches/objc-gf/ccl/examples/tiny.lisp

    r5884 r6112  
    4343(defconstant numsides 12)
    4444
    45 (define-objc-method ((:void :draw-rect (:<NSR>ect rect))
    46                      demo-view)
     45(objc:defmethod (#/drawRect: :void) ((self demo-view) (rect :<NSR>ect))
    4746  (declare (ignore rect))
    48   (slet ((bounds (send self 'bounds)))
    49     (let ((width (ns-width bounds))
    50           (height (ns-height bounds)))
    51       (macrolet ((X (tt) `(* (1+ (sin ,tt)) width 0.5))
    52                  (Y (tt) `(* (1+ (cos ,tt)) height 0.5)))
    53         ;; Fill the view with white
    54         (send (the ns-color (send (@class ns-color) 'white-color)) 'set)
    55         (#_NSRectFill bounds)
    56         ;; Trace two polygons with N sides and connect all of the vertices
    57         ;; with lines
    58         (send (the ns-color (send (@class ns-color) 'black-color)) 'set)
     47  (let* ((bounds (#/bounds self))
     48         (width (ns:ns-rect-width bounds))
     49         (height (ns:ns-rect-height bounds)))
     50    (macrolet ((X (tt) `(* (1+ (sin ,tt)) width 0.5))
     51               (Y (tt) `(* (1+ (cos ,tt)) height 0.5)))
     52      ;; Fill the view with white
     53      (#/set (#/whiteColor ns:ns-color))
     54      (#_NSRectFill bounds)
     55      ;; Trace two polygons with N sides and connect all of the vertices
     56      ;; with lines
     57      (#/set (#/blackColor ns:ns-color))
     58      (rlet ((source-point :ns-point)
     59             (dest-point :ns-point))
     60      (loop
     61        for f from 0.0 below (* 2 short-pi) by (* 2 (/ short-pi numsides))
     62        do
    5963        (loop
    60           for f from 0.0 below (* 2 short-pi) by (* 2 (/ short-pi numsides))
     64          for g from 0.0 below (* 2 short-pi) by (* 2 (/ short-pi numsides))
    6165          do
    62           (loop
    63             for g from 0.0 below (* 2 short-pi) by (* 2 (/ short-pi numsides))
    64             do
    65             (send (@class ns-bezier-path)
    66                   :stroke-line-from-point (ns-make-point (X f) (Y f))
    67                   :to-point (ns-make-point (X g) (Y g)))))))))
     66          (ns:init-ns-point source-point (X f) (Y f))
     67          (ns:init-ns-point dest-point (X g) (Y g))
     68          (#/strokeLineFromPoint:toPoint: ns:ns-bezier-path source-point dest-point)))))))
    6869
    6970
     
    7374(defun tiny-setup ()
    7475  (with-autorelease-pool
    75    (slet ((r (ns-make-rect (float 100.0 +cgfloat-zero+)
    76                            (float 350.0 +cgfloat-zero+)
    77                            (float 400.0 +cgfloat-zero+)
    78                            (float 400.0 +cgfloat-zero+))))
    79          (let ((w (make-instance
     76    (let* ((r (ns:make-ns-rect 100 350 400 400))
     77           (w (make-instance
    8078                   'ns:ns-window
    8179                   :with-content-rect r
     
    8583                   :backing #$NSBackingStoreBuffered
    8684                   :defer t)))
    87            (send w :set-title #@"Tiny Window Application")
    88            (let ((my-view (make-instance 'demo-view :with-frame r)))
    89              (send w :set-content-view my-view)
    90              (send w :set-delegate my-view))
    91            (send w :make-key-and-order-front nil)
    92            w))))
     85      (#/setTitle: w "Tiny Window Application")
     86      (let ((my-view (make-instance 'demo-view :with-frame r)))
     87        (#/setContentView: w my-view)
     88        (#/setDelegate: w my-view))
     89      (#/makeKeyAndOrderFront: w nil)
     90      w)))
    9391
    9492
Note: See TracChangeset for help on using the changeset viewer.