Changeset 6234


Ignore:
Timestamp:
Apr 8, 2007, 5:07:28 PM (13 years ago)
Author:
gb
Message:

Use new syntax: OBJC:DEFMETHOD, #/, MAKE-INSTANCE.

Some changes in font, nsstring stuff to avoid using deprecated
featurs.

Location:
trunk/ccl/examples
Files:
10 edited

Legend:

Unmodified
Added
Removed
  • trunk/ccl/examples/cocoa-application.lisp

    r4790 r6234  
    3535  (or (getenv "CCL_DEFAULT_DIRECTORY")
    3636      (with-autorelease-pool
    37           (let* ((bundle (send (@class ns-bundle) 'main-bundle))
     37          (let* ((bundle (#/mainBundle ns:ns-bundle))
    3838                 (ccl-dir (unless (%null-ptr-p bundle)
    39                             (send bundle :object-for-info-dictionary-key
     39                            (#/objectForInfoDictionaryKey: bundle
    4040                                  #@"CCLDefaultDirectory")))
    4141                 (bundle-path (unless (%null-ptr-p bundle)
    42                                 (send bundle 'bundle-path))))
     42                                (#/bundlePath bundle))))
    4343            (when (and ccl-dir (not (%null-ptr-p ccl-dir))
    4444                       bundle-path (not (%null-ptr-p bundle-path)))
  • trunk/ccl/examples/cocoa-backtrace.lisp

    r5732 r6234  
    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
    38 (define-objc-method ((:void close)
    39                      backtrace-window-controller)
     36(objc:defmethod (#/close :void) ((self backtrace-window-controller))
    4037  (setf (slot-value self 'context) nil)
    41   (send-super 'close))
     38  (call-next-method))
    4239
    4340(defmethod our-frame-label-p ((self backtrace-window-controller) thing)
     
    4542       (eql self (frame-label-controller thing))))
    4643
    47 (define-objc-method ((:void window-did-load)
    48                      backtrace-window-controller)
     44(objc:defmethod (#/windowDidLoad :void) ((self backtrace-window-controller))
    4945  (let* ((outline (slot-value self 'outline-view))
    5046         (font (default-font :name "Monaco" :size 12)))
    5147    (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)
     48      (let* ((columns (#/tableColumns outline)))
     49        (dotimes (i (#/count columns))
     50          (let* ((column (#/objectAtIndex:  columns i))
     51                 (data-cell (#/dataCell column)))
     52            (#/setFont: data-cell font)
    5753            (when (eql i 0)
    58               (let* ((header-cell (send column 'header-cell))
     54              (let* ((header-cell (#/headerCell column))
    5955                     (inspector (backtrace-controller-inspector self))
    6056                     (break-condition
     
    6965                                break-condition))))
    7066                     
    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)))
     67                (#/setFont: header-cell (default-font :attributes '(:bold)))
     68                (#/setStringValue: header-cell (%make-nsstring break-condition-string))))))))
     69    (let* ((window (#/window  self)))
    7570      (unless (%null-ptr-p window)
    7671        (let* ((context (backtrace-controller-context self))
    7772               (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)))))))))
     73          (#/setTitle:  window (%make-nsstring
     74                                (format nil "Backtrace for ~a(~d), break level ~d"
     75                                        (process-name process)
     76                                        (process-serial-number process)
     77                                        (bt.break-level context)))))))))
    8378
    84              
    85 (define-objc-method ((:<BOOL> :outline-view view
    86                               :is-item-expandable item)
    87                      backtrace-window-controller)
     79(objc:defmethod (#/outlineView:isItemExpandable: :<BOOL>)
     80    ((self backtrace-window-controller) view item)
    8881    (declare (ignore view))
    8982    (or (%null-ptr-p item)
    9083        (our-frame-label-p self item)))
    9184
    92 (define-objc-method ((:<NSI>nteger :outline-view view
    93                                    :number-of-children-of-item item)
    94                      backtrace-window-controller)
     85(objc:defmethod (#/outlineView:numberOfChildrenOfItem: :<NSI>nteger)
     86    ((self backtrace-window-controller) view item)
    9587    (declare (ignore view))
    9688    (let* ((inspector (backtrace-controller-inspector self)))
     
    108100               (inspector::inspector-line-count frame-inspector)))
    109101            (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))
     102
     103(objc:defmethod #/outlineView:child:ofItem:
     104    ((self backtrace-window-controller) view (index :<NSI>nteger) item)
     105  (declare (ignore view))
    116106  (let* ((inspector (backtrace-controller-inspector self)))
    117107    (cond ((%null-ptr-p item)
     
    154144          (t (break) (%make-nsstring "Huh?")))))
    155145
    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)))
     146(objc:defmethod #/outlineView:objectValueForTableColumn:byItem:
     147    ((self backtrace-window-controller) view column item)
     148  (declare (ignore view column))
     149  (if (%null-ptr-p item)
     150    #@"Open this"
     151    (%setf-macptr (%null-ptr) item)))
    164152
    165153(defmethod initialize-instance :after ((self backtrace-window-controller)
     
    176164
    177165#+debug
    178 (define-objc-method ((:void will-load)
    179                      backtrace-window-controller)
    180   (#_NSLog #@"will load %@" :address (send self 'window-nib-name)))
     166(objc:defmethod (#/willLoad :void) ((self backtrace-window-controller))
     167  (#_NSLog #@"will load %@" :address  (#/windowNibName self)))
    181168
    182169(defmethod ui-object-enter-backtrace-context ((app ns:ns-application)
     
    195182        (let* ((window (bt.dialog context)))
    196183          (when window
    197             (send window
    198                   :perform-selector-on-main-thread
    199                   (@selector "close")
    200                   :with-object (%null-ptr)
    201                   :wait-until-done t)))))))
     184            (#/performSelectorOnMainThread:withObject:waitUntilDone: window (@selector @/close)  +null-ptr+ t)))))))
    202185
    203186 
  • trunk/ccl/examples/cocoa-defaults.lisp

    r763 r6234  
    5858
    5959(defun %define-cocoa-default (name type value doc &optional constraint)
    60   (proclaim `(special name))
     60  (proclaim `(special ,name))
    6161  ;; Make the variable "GLOBAL": its value can be changed, but it can't
    6262  ;; have a per-thread binding.
     
    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))))
  • trunk/ccl/examples/cocoa-editor.lisp

    r5901 r6234  
    1 ;;;-*- Mode: LISP; Package: CCL -*-
     1;;-*- Mode: LISP; Package: CCL -*-
    22
    33
     
    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))
     
    320320         (hi::*buffer-gap-context*
    321321          (hi::buffer-gap-context (buffer-cache-buffer cache))))
    322     #+debug 0
     322    #+debug
    323323    (#_NSLog #@"get line start: %d/%d"
    324324             :unsigned index
     
    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))
     
    360361    (hi::%set-buffer-modified buffer nil)
    361362    (if (eql 0 raw-length)
    362       (make-objc-instance 'ns:ns-mutable-data :with-length 0)
     363      (make-instance 'ns:ns-mutable-data :with-length 0)
    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)))
     
    376377               (when next (incf raw-length))))
    377378           (let* ((pos 0)
    378                   (data (make-objc-instance 'ns:ns-mutable-data
    379                                             :with-length raw-length))
    380                   (bytes (send data 'mutable-bytes)))
     379                  (data (make-instance 'ns:ns-mutable-data
     380                                       :with-length raw-length))
     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  (ns:with-ns-range (r pos 0)
     437    (#/edited:range:changeInLength: self #$NSTextStorageEditedAttributes r n)
     438    (setf (ns:ns-range-length r) n)
     439    (#/edited:range:changeInLength: self #$NSTextStorageEditedCharacters r 0)))
     440
     441(objc:defmethod (#/noteInsertion: :void) ((self hemlock-text-storage) params)
     442  (let* ((pos (#/longValue (#/objectAtIndex: params 0)))
     443         (n (#/longValue (#/objectAtIndex: params 1))))
    445444    (textstorage-note-insertion-at-position self pos n)))
    446445
    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))))
     446(objc:defmethod (#/noteDeletion: :void) ((self hemlock-text-storage) params)
     447  (let* ((pos (#/longValue (#/objectAtIndex: params 0)))
     448         (n (#/longValue (#/objectAtIndex: params 1))))
     449    (rlet ((range :ns-range :location pos :length n))
     450      (#/edited:range:changeInLength: self #$NSTextStorageEditedCharacters range (- n)))
     451    (let* ((display (hemlock-buffer-string-cache (#/string self))))
    455452      (reset-buffer-cache display)
    456453      (update-line-cache-for-index display pos))))
    457454
    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)))
     455(objc:defmethod (#/noteModification: :void) ((self hemlock-text-storage) params)
     456  (let* ((pos (#/longValue (#/objectAtIndex: params 0)))
     457         (n (#/longValue (#/objectAtIndex: params 1))))
    461458    #+debug
    462459    (#_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)))
     460    (rlet ((range :ns-range :location pos :length n))
     461      (#/edited:range:changeInLength: self (logior #$NSTextStorageEditedCharacters
     462                                                  #$NSTextStorageEditedAttributes) range 0))))
     463
     464(objc:defmethod (#/noteAttrChange: :void) ((self hemlock-text-storage) params)
     465  (let* ((pos (#/longValue (#/objectAtIndex: params 0)))
     466         (n (#/longValue (#/objectAtIndex: params 1))))
    472467    #+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)
     468    (rlet ((range :ns-range :location pos :length n))
     469      (#/edited:range:changeInLength: self #$NSTextStorageEditedAttributes range 0))))
     470
     471(objc:defmethod (#/beginEditing :void) ((self hemlock-text-storage))
    479472  #+debug
    480473  (#_NSLog #@"begin-editing")
     
    482475  #+debug
    483476  (#_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)
     477  (call-next-method))
     478
     479(objc:defmethod (#/endEditing :void) ((self hemlock-text-storage))
    487480  #+debug
    488481  (#_NSLog #@"end-editing")
    489   (send-super 'end-editing)
     482  (call-next-method)
    490483  (decf (slot-value self 'edit-count))
    491484  #+debug
     
    493486
    494487;;; Return true iff we're inside a "beginEditing/endEditing" pair
    495 (define-objc-method ((:<BOOL> editing-in-progress) hemlock-text-storage)
     488(objc:defmethod (#/editingInProgress :<BOOL>) ((self hemlock-text-storage))
    496489  (not (eql (slot-value self 'edit-count) 0)))
    497490
     
    500493;;; Access the string.  It'd be nice if this was a generic function;
    501494;;; we could have just made a reader method in the class definition.
    502 (define-objc-method ((:id string) hemlock-text-storage)
     495(objc:defmethod #/string ((self hemlock-text-storage))
    503496  (slot-value self 'string))
    504497
    505 (define-objc-method ((:id :init-with-string s) hemlock-text-storage)
    506   (let* ((newself (send-super 'init)))
     498(objc:defmethod #/initWithString: ((self hemlock-text-storage) s)
     499  (let* ((newself (#/init self)))
    507500    (setf (slot-value newself 'string) s)
    508501    newself))
     
    512505;;; hemlock-buffer-string.)
    513506(defun make-textstorage-for-hemlock-buffer (buffer)
    514   (make-objc-instance 'hemlock-text-storage
    515                       :with-string
    516                       (make-instance
    517                        'hemlock-buffer-string
    518                        :cache
    519                        (reset-buffer-cache
    520                         (make-buffer-cache)
    521                         buffer))))
    522 
    523 (define-objc-method ((:id :attributes-at-index (:<NSUI>nteger index)
    524                           :effective-range ((* :<NSR>ange) rangeptr))
    525                      hemlock-text-storage)
     507  (make-instance 'hemlock-text-storage
     508                 :with-string
     509                 (make-instance
     510                  'hemlock-buffer-string
     511                  :cache
     512                  (reset-buffer-cache
     513                   (make-buffer-cache)
     514                   buffer))))
     515
     516(objc:defmethod #/attributesAtIndex:effectiveRange:
     517    ((self hemlock-text-storage) (index :<NSUI>nteger) (rangeptr (* :<NSR>ange)))
    526518  #+debug
    527   (#_NSLog #@"Attributes at index: %d" :unsigned index)
     519  (#_NSLog #@"Attributes at index: %ld" :<NSUI>nteger index)
    528520  (let* ((buffer-cache (hemlock-buffer-string-cache (slot-value self 'string)))
    529521         (buffer (buffer-cache-buffer buffer-cache))
     
    552544      (svref *styles* style))))
    553545
    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)))
     546(objc:defmethod (#/replaceCharactersInRange:withString: :void)
     547    ((self hemlock-text-storage) (r :<NSR>ange) string)
     548  (let* ((cache (hemlock-buffer-string-cache (#/string  self)))
    558549         (buffer (if cache (buffer-cache-buffer cache)))
    559550         (hi::*buffer-gap-context* (hi::buffer-gap-context buffer))
     
    563554         (point (hi::buffer-point buffer))
    564555         input-mark)
    565 
    566556    ;;
    567557    ;; special behavior for listener windows.
     
    587577
    588578;;; 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)
     579;;; attributes in the buffer.  This method is only here so we can
     580;;; see if/when it tries to do so.
     581(objc:defmethod (#/setAttributes:range: :void) ((self hemlock-text-storage)
     582                                                attributes
     583                                                (r :<NSR>ange))
    593584  (declare (ignorable attributes r))
    594585  #+debug
     
    599590
    600591(defun for-each-textview-using-storage (textstorage f)
    601   (let* ((layouts (send textstorage 'layout-managers)))
     592  (let* ((layouts (#/layoutManagers textstorage)))
    602593    (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)))
     594      (dotimes (i (#/count layouts))
     595        (let* ((layout (#/objectAtIndex: layouts i))
     596               (containers (#/textContainers layout)))
    606597          (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)))
     598            (dotimes (j (#/count containers))
     599              (let* ((container (#/objectAtIndex: containers j))
     600                     (tv (#/textView container)))
    610601                (funcall f tv)))))))))
    611602
    612603;;; 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))))
     604(objc:defmethod #/description ((self hemlock-text-storage))
     605  (#/stringWithFormat: ns:ns-string #@"%s : string %@" (#_object_getClassName self) (slot-value self 'string)))
    617606
    618607;;; This needs to happen on the main thread.
    619 (define-objc-method ((:void ensure-selection-visible)
    620                      hemlock-text-storage)
     608(objc:defmethod (#/ensureSelectionVisible :void) ((self hemlock-text-storage))
    621609  (for-each-textview-using-storage
    622610   self
    623611   #'(lambda (tv)
    624        (send tv :scroll-range-to-visible (send tv 'selected-range)))))
     612       (#/scrollRangeToVisible: tv (#/selectedRange tv)))))
    625613
    626614
     
    661649(def-cocoa-default *layout-text-in-background* :int 1 "When non-zero, do text layout when idle.")
    662650
    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))
     651(objc:defmethod (#/layoutManager:didCompleteLayoutForTextContainer:atEnd: :void)
     652    ((self hemlock-textstorage-text-view) layout cont (flag :<BOOL>))
     653  (declare (ignorable cont flag))
    668654  (when (zerop *layout-text-in-background*)
    669     (send layout :set-delegate (%null-ptr))
    670     (send layout :set-background-layout-enabled nil)))
     655    (#/setDelegate: layout +null-ptr+)
     656    (#/setBackgroundLayoutEnabled: layout nil)))
    671657   
    672658;;; Note changes to the textview's background color; record them
    673659;;; as the value of the "temporary" foreground color (for blinking).
    674 (define-objc-method ((:void :set-background-color color)
    675                      hemlock-textstorage-text-view)
     660(objc:defmethod (#/setBackgroundColor: :void)
     661    ((self hemlock-textstorage-text-view) color)
    676662  (setf (text-view-blink-color self) color)
    677   (send-super :set-background-color color))
     663  (call-next-method color))
    678664
    679665;;; Maybe cause 1 character in the textview to blink (by drawing an empty
    680666;;; character rectangle) in synch with the insertion point.
    681667
    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)
     668(objc:defmethod (#/drawInsertionPointInRect:color:turnedOn: :void)
     669    ((self hemlock-textstorage-text-view)
     670     (r :<NSR>ect)
     671     color
     672     (flag :<BOOL>))
     673  (unless (#/editingInProgress (#/textStorage self))
    687674    (unless (eql #$NO (text-view-blink-enabled self))
    688       (let* ((layout (send self 'layout-manager))
    689              (container (send self 'text-container))
     675      (let* ((layout (#/layoutManager self))
     676             (container (#/textContainer self))
    690677             (blink-color (text-view-blink-color self)))
    691678        ;; We toggle the blinked character "off" by setting its
     
    693680        ;; The blinked character should be "on" whenever the insertion
    694681        ;; 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))
     682        (ns:with-ns-range  (char-range (text-view-blink-location self) 1)
     683          (let* ((glyph-range (#/glyphRangeForCharacterRange:actualCharacterRange:
     684                               layout
     685                               char-range
     686                               +null-ptr+)))
     687            #+debug (#_NSLog #@"Flag = %d, location = %d" :<BOOL> (if flag #$YES #$NO) :int (text-view-blink-location self))
     688            (let* ((rect (#/boundingRectForGlyphRange:inTextContainer:
     689                          layout
     690                          glyph-range
     691                          container)))
     692              (#/set blink-color)
     693              (#_NSRectFill rect))
    706694          (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)))
     695            (#/drawGlyphsForGlyphRange:atPoint: layout glyph-range (#/textContainerOrigin self)))))))
     696    (call-next-method r color flag)))
    714697               
    715698(defmethod disable-blink ((self hemlock-textstorage-text-view))
     
    718701    ;; Force the blinked character to be redrawn.  Let the text
    719702    ;; 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)))))
     703    (let* ((layout (#/layoutManager self)))
     704      (rlet ((invalid-range :ns-range
     705                            :location  (text-view-blink-location self)
     706                            :length 1))
     707        (#/invalidateDisplayForCharacterRange: layout invalid-range)))))
    723708
    724709(defmethod update-blink ((self hemlock-textstorage-text-view))
    725710  (disable-blink self)
    726   (let* ((d (hemlock-buffer-string-cache (send self 'string)))
     711  (let* ((d (hemlock-buffer-string-cache (#/string self)))
    727712         (buffer (buffer-cache-buffer d)))
    728713    (when (and buffer (string= (hi::buffer-major-mode buffer) "Lisp"))
     
    752737;;; affinity is affinity.  This should never be called from any Cocoa
    753738;;; 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)
    759   (when (eql len 0)
     739;;; underlying buffer's point and/or mark
     740
     741(objc:defmethod (#/updateSelection:length:affinity: :void)
     742    ((self hemlock-textstorage-text-view)
     743     (pos :int)
     744     (length :int)
     745     (affinity :<NSS>election<A>ffinity))
     746  (when (eql length 0)
    760747    (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)))
     748  (rlet ((range :ns-range :location pos :length length))
     749    (%call-next-objc-method self
     750                            hemlock-textstorage-text-view
     751                            (@selector #/setSelectedRange:affinity:stillSelecting:)
     752                            '(:void :<NSR>ange :<NSS>election<A>ffinity :<BOOL>)
     753                            range
     754                            affinity
     755                            nil)
     756    (#/scrollRangeToVisible: self range)))
    766757 
    767758;;; A specialized NSTextView. The NSTextView is part of the "pane"
     
    773764;;; Access the underlying buffer in one swell foop.
    774765(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)
     766  (buffer-cache-buffer (hemlock-buffer-string-cache (#/string (#/textStorage self)))))
     767
     768(objc:defmethod (#/setString: :void) ((self hemlock-textstorage-text-view) s)
     769  #+debug
    779770  (#_NSLog #@"hemlock-text-view %@ string set to %@" :id self :id s)
    780   (send-super :set-string s))
    781 
    782 (define-objc-method (((:struct :_<NSR>ange r)
    783                       :selection-range-for-proposed-range (:<NSR>ange proposed)
    784                       :granularity (:<NSS>election<G>ranularity g))
    785                      hemlock-textstorage-text-view)
     771  (call-next-method) s)
     772
     773(objc:defmethod (#/selectionRangeForProposedRange:granularity: :ns-range)
     774    ((self hemlock-textstorage-text-view)
     775     (proposed :ns-range)
     776     (g :<NSS>election<G>ranularity))
    786777  #+debug
    787778  (#_NSLog #@"Granularity = %d" :int g)
    788   (block HANDLED
    789     (let* ((index (pref proposed :<NSR>ange.location))
    790            (length (pref proposed :<NSR>ange.length)))
     779  (objc:returning-foreign-struct (r)
     780    (block HANDLED
     781      (let* ((index (ns:ns-range-location proposed))             
     782             (length (ns:ns-range-length proposed)))
    791783      (when (and (eql 0 length)              ; not extending existing selection
    792784                 (not (eql g #$NSSelectByCharacter)))
    793         (let* ((textstorage (send self 'text-storage))
    794                (cache (hemlock-buffer-string-cache (send textstorage 'string)))
     785        (let* ((textstorage (#/textStorage self))
     786               (cache (hemlock-buffer-string-cache (#/string textstorage)))
    795787               (buffer (if cache (buffer-cache-buffer cache))))
    796788          (when (and buffer (string= (hi::buffer-major-mode buffer) "Lisp"))
     
    803795                         (hi::with-mark ((m2 m1))
    804796                           (when (hemlock::list-offset m2 1)
    805                              (setf (pref r :<NSR>ange.location) index
    806                                    (pref r :<NSR>ange.length)
    807                                    (- (mark-absolute-position m2) index))
    808                              (return-from HANDLED nil))))
     797                             (ns:init-ns-range r index (- (mark-absolute-position m2) index))
     798                             (return-from HANDLED r))))
    809799                        ((eql (hi::previous-character m1) #\))
    810800                         (hi::with-mark ((m2 m1))
    811801                           (when (hemlock::list-offset m2 -1)
    812                              (setf (pref r :<NSR>ange.location)
    813                                    (mark-absolute-position m2)
    814                                    (pref r :<NSR>ange.length)
    815                                    (- index (mark-absolute-position m2)))
    816                              (return-from HANDLED nil))))))))))))
    817     (send-super/stret r
    818                       :selection-range-for-proposed-range proposed
    819                       :granularity g)
    820     #+debug
    821     (#_NSLog #@"range = %@, proposed = %@, granularity = %d"
    822              :address (#_NSStringFromRange r)
    823              :address (#_NSStringFromRange proposed)
    824              :<NSS>election<G>ranularity g)))
     802                             (ns:init-ns-range r (mark-absolute-position m2) (- index (mark-absolute-position m2)))
     803                             (return-from HANDLED r))))))))))))
     804      (call-next-method proposed g)
     805      #+debug
     806      (#_NSLog #@"range = %@, proposed = %@, granularity = %d"
     807               :address (#_NSStringFromRange r)
     808               :address (#_NSStringFromRange proposed)
     809               :<NSS>election<G>ranularity g))))
     810
     811 
     812
    825813
    826814;;; Translate a keyDown NSEvent to a Hemlock key-event.
    827815(defun nsevent-to-key-event (nsevent)
    828   (let* ((unmodchars (send nsevent 'characters-ignoring-modifiers))
     816  (let* ((unmodchars (#/charactersIgnoringModifiers nsevent))
    829817         (n (if (%null-ptr-p unmodchars)
    830818              0
    831               (send (the ns:ns-string unmodchars) 'length)))
     819              (#/length unmodchars)))
    832820         (c (if (eql n 1)
    833               (send unmodchars :character-at-index 0))))
     821              (#/characterAtIndex: unmodchars 0))))
    834822    (when c
    835823      (let* ((bits 0)
    836              (modifiers (send nsevent 'modifier-flags))
     824             (modifiers (#/modifierFlags nsevent))
    837825             (useful-modifiers (logandc2 modifiers
    838826                                         (logior #$NSShiftKeyMask
     
    849837  (let* ((buffer (text-view-buffer self)))
    850838    (when buffer
    851       (let* ((q (hemlock-frame-event-queue (send self 'window))))
     839      (let* ((q (hemlock-frame-event-queue (#/window self))))
    852840        (hi::enqueue-key-event q (nsevent-to-key-event event))))))
    853841
    854842(defun enqueue-buffer-operation (buffer thunk)
    855843  (dolist (w (hi::buffer-windows buffer))
    856     (let* ((q (hemlock-frame-event-queue (send w 'window)))
     844    (let* ((q (hemlock-frame-event-queue (#/window w)))
    857845           (op (hi::make-buffer-operation :thunk thunk)))
    858846      (hi::event-queue-insert q op))))
     
    863851;;; interpreter.
    864852
    865 (define-objc-method ((:void :key-down event)
    866                      hemlock-text-view)
     853(objc:defmethod (#/keyDown: :void) ((self hemlock-text-view) event)
    867854  (pass-key-down-event-to-hemlock self event))
    868855
     
    870857;;; This is called in response to a mouse click or other event; it shouldn't
    871858;;; 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)
     859
     860(objc:defmethod (#/setSelectedRange:affinity:stillSelecting: :void)
     861    ((self hemlock-text-view)
     862     (r :<NSR>ange)
     863     (affinity :<NSS>election<A>ffinity)
     864     (still-selecting :<BOOL>))
    876865  #+debug
    877866  (#_NSLog #@"Set selected range called: location = %d, length = %d, affinity = %d, still-selecting = %d"
     
    882871  #+debug
    883872  (#_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)))
     873           :id (#/string self)
     874           :id (#/string (#/textStorage self)))
     875  (unless (#/editingInProgress (#/textStorage self))
     876    (let* ((d (hemlock-buffer-string-cache (#/string self)))
    888877           (buffer (buffer-cache-buffer d))
    889878           (hi::*buffer-gap-context* (hi::buffer-gap-context buffer))
     
    908897             ;; d: range: {n1,m} still-selecting: false  [ rarely repeats ]
    909898             ;;
    910              ;; (Sadly, "affinity" doesn't tell us anything interesting.
     899             ;; (Sadly, "affinity" doesn't tell us anything interesting.)
    911900             ;; We've handled a and b in the clause above; after handling
    912901             ;; b, point references buffer position n0 and the
     
    940929                                                                  selection-end)))
    941930                   (hemlock::%buffer-push-buffer-mark buffer mark t)))))))
    942   (send-super :set-selected-range r
    943               :affinity affinity
    944               :still-selecting still-selecting))
     931  (call-next-method r affinity still-selecting))
    945932
    946933
     
    985972;;; early in the loading sequence confuses some Carbon libraries that're
    986973;;; used in the event dispatch mechanism,
    987 (defun draw-modeline-string (modeline-view)
    988   (let* ((pane (modeline-view-pane modeline-view))
    989          (buffer (buffer-for-modeline-view modeline-view)))
     974(defun draw-modeline-string (the-modeline-view)
     975  (let* ((pane (modeline-view-pane the-modeline-view))
     976         (buffer (buffer-for-modeline-view the-modeline-view)))
    990977    (when buffer
    991978      ;; You don't want to know why this is done this way.
    992979      (unless *modeline-text-attributes*
    993980        (setq *modeline-text-attributes*
    994               (create-text-attributes :color (send (@class "NSColor") 'black-color)
     981              (create-text-attributes :color (#/blackColor ns:ns-color)
    995982                                      :font (default-font
    996983                                              :name *modeline-font-name*
     
    1004991                                   buffer pane))
    1005992                      (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*)))))
     993        (rletZ ((zpoint :ns-point))
     994          (#/drawAtPoint:withAttributes: (%make-nsstring string)
     995                                         zpoint
     996                                         *modeline-text-attributes*))))))
    1009997
    1010998;;; Draw the underlying buffer's modeline string on a white background
    1011999;;; with a bezeled border around it.
    1012 (define-objc-method ((:void :draw-rect (:<NSR>ect rect))
    1013                      modeline-view)
    1014   (declare (ignore rect))
    1015   (slet ((frame (send self 'bounds)))
     1000(objc:defmethod (#/drawRect: :void) ((self modeline-view) (rect :<NSR>ect))
     1001  (declare (ignorable rect))
     1002  (let* ((frame (#/bounds self)))
    10161003     (#_NSDrawWhiteBezel frame frame)
    10171004     (draw-modeline-string self)))
     
    10361023;;; modeline view, as well.
    10371024
    1038 (define-objc-method ((:id :init-with-frame (:<NSR>ect frame))
    1039                      modeline-scroll-view)
    1040     (let* ((v (send-super :init-with-frame frame)))
     1025(objc:defmethod #/initWithFrame: ((self modeline-scroll-view) (frame :<NSR>ect))
     1026    (let* ((v (call-next-method frame)))
    10411027      (when v
    1042         (let* ((modeline (make-objc-instance 'modeline-view)))
    1043           (send v :add-subview modeline)
     1028        (let* ((modeline (make-instance 'modeline-view)))
     1029          (#/addSubview: v modeline)
    10441030          (setf (scroll-view-modeline v) modeline)))
    10451031      v))
     
    10491035;;; scroll bar and place the modeline view there.
    10501036
    1051 (define-objc-method ((:void tile) modeline-scroll-view)
    1052   (send-super 'tile)
     1037(objc:defmethod (#/tile :void) ((self modeline-scroll-view))
     1038  (call-next-method)
    10531039  (let* ((modeline (scroll-view-modeline self)))
    1054     (when (and (send self 'has-horizontal-scroller)
     1040    (when (and (#/hasHorizontalScroller self)
    10551041               (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 cg-float single-float modeline-width))
    1063              (setf (pref modeline-frame :<NSR>ect.size.width)
    1064                    modeline-width
    1065                    (the cg-float
    1066                      (pref scrollbar-frame :<NSR>ect.size.width))
    1067                    (- (the cg-float
    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 cg-float
    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)))))))
     1042      (let* ((hscroll (#/horizontalScroller self))
     1043             (scrollbar-frame (#/frame hscroll))
     1044             (modeline-frame (#/frame hscroll)) ; sic
     1045             (modeline-width (* (pref modeline-frame
     1046                                      :<NSR>ect.size.width)
     1047                                0.75f0)))
     1048        (declare (type cgfloat modeline-width))
     1049        (setf (pref modeline-frame :<NSR>ect.size.width)
     1050              modeline-width
     1051              (the cgfloat
     1052                (pref scrollbar-frame :<NSR>ect.size.width))
     1053              (- (the cgfloat
     1054                   (pref scrollbar-frame :<NSR>ect.size.width))
     1055                 modeline-width)
     1056              (the cg-float
     1057                (pref scrollbar-frame :<NSR>ect.origin.x))
     1058              (+ (the cgfloat
     1059                   (pref scrollbar-frame :<NSR>ect.origin.x))
     1060                 modeline-width))
     1061        (#/setFrame: hscroll scrollbar-frame)
     1062        (#/setFrame: modeline modeline-frame)))))
    10771063
    10781064;;; We want to constrain the scrolling that happens under program control,
    10791065;;; so that the clipview is always scrolled in character-sized increments.
    10801066#+doesnt-work-yet
    1081 (define-objc-method ((:void :scroll-clip-view clip-view :to-point (:<NSP>oint p))
    1082                      modeline-scroll-view)
     1067(objc:defmethod (#/scrollClipView:toPoint: :void)
     1068    ((self modeline-scroll-view)
     1069     clip-view
     1070     (p :ns-point))
    10831071  #+debug
    10841072  (#_NSLog #@"Scrolling to point %@" :id (#_NSStringFromPoint p))
    1085  
    1086   (let* ((char-height (send self 'vertical-line-scroll)))
    1087     (slet ((proposed (ns-make-point (pref p :<NSP>oint.x)
    1088                                          (* char-height
    1089                                             (round (pref p :<NSP>oint.y)
    1090                                                     char-height)))))
     1073  (let* ((char-height (#/verticalLineScroll self)))
     1074    (ns:with-ns-point (proposed (ns:ns-point-x p) (* char-height (round (ns:ns-point-y p) char-height)))
    10911075    #+debug
    10921076    (#_NSLog #@" Proposed point = %@" :id
    10931077             (#_NSStringFromPoint proposed)))
    1094     (send-super :scroll-clip-view clip-view
    1095                 :to-point p #+nil (ns-make-point (pref p :<NSP>oint.x)
    1096                                          (* char-height
    1097                                             (ffloor (pref p :<NSP>oint.y)
    1098                                                     char-height))))))
     1078    (call-next-method clip-view proposed)))
    10991079
    11001080
     
    11161096
    11171097(defun hi::invalidate-modeline (pane)
    1118   (send (text-pane-mode-line pane) :set-needs-display t))
     1098  (#/setNeedsDisplay: (text-pane-mode-line pane) t))
    11191099
    11201100(def-cocoa-default *text-pane-margin-width* :float 0.0f0 "width of indented margin around text pane")
     
    11221102
    11231103
    1124 (define-objc-method ((:id :init-with-frame (:<NSR>ect frame))
    1125                      text-pane)
    1126     (let* ((pane (send-super :init-with-frame frame)))
    1127       (unless (%null-ptr-p pane)
    1128         (send pane :set-autoresizing-mask (logior
    1129                                            #$NSViewWidthSizable
    1130                                            #$NSViewHeightSizable))
    1131         (send pane :set-box-type #$NSBoxPrimary)
    1132         (send pane :set-border-type #$NSNoBorder)
    1133         (send pane :set-content-view-margins (ns-make-size (float *text-pane-margin-width* +cgfloat-zero+) (float *text-pane-margin-height* +cgfloat-zero+)))
    1134         (send pane :set-title-position #$NSNoTitle))
    1135       pane))
     1104(objc:defmethod #/initWithFrame: ((self text-pane) (frame :<NSR>ect))
     1105  (let* ((pane (call-next-method frame)))
     1106    (unless (%null-ptr-p pane)
     1107      (#/setAutoresizingMask: pane (logior
     1108                                    #$NSViewWidthSizable
     1109                                    #$NSViewHeightSizable))
     1110      (#/setBoxType: pane #$NSBoxPrimary)
     1111      (#/setBorderType: pane #$NSNoBorder)
     1112      (#/setContentViewMargins: pane (ns:make-ns-size *text-pane-margin-width*  *text-pane-margin-height*))
     1113      (#/setTitlePosition: pane #$NSNoTitle))
     1114    pane))
    11361115
    11371116
    11381117(defun make-scrolling-text-view-for-textstorage (textstorage x y width height tracks-width color)
    1139   (slet ((contentrect (ns-make-rect
    1140                        (float x +cgfloat-zero+)
    1141                        (float y +cgfloat-zero+)
    1142                        (float width +cgfloat-zero+)
    1143                        (float height +cgfloat-zero+))))
    1144     (let* ((scrollview (send (make-objc-instance
    1145                               'modeline-scroll-view
    1146                               :with-frame contentrect) 'autorelease)))
    1147       (send scrollview :set-border-type #$NSBezelBorder)
    1148       (send scrollview :set-has-vertical-scroller t)
    1149       (send scrollview :set-has-horizontal-scroller t)
    1150       (send scrollview :set-rulers-visible nil)
    1151       (send scrollview :set-autoresizing-mask (logior
    1152                                                #$NSViewWidthSizable
    1153                                                #$NSViewHeightSizable))
    1154       (send (send scrollview 'content-view) :set-autoresizes-subviews t)
    1155       (let* ((layout (make-objc-instance 'ns-layout-manager)))
    1156         (send textstorage :add-layout-manager layout)
    1157         (send layout 'release)
    1158         (slet* ((contentsize (send scrollview 'content-size))
    1159                 (containersize (ns-make-size
    1160                                 large-number-for-text
    1161                                 large-number-for-text))
    1162                 (tv-frame (ns-make-rect
    1163                            +cgfloat-zero+
    1164                            +cgfloat-zero+
    1165                            (pref contentsize :<NSS>ize.width)
    1166                            (pref contentsize :<NSS>ize.height))))
    1167           (let* ((container (send (make-objc-instance
    1168                                    'ns-text-container
    1169                                    :with-container-size containersize)
    1170                                   'autorelease)))
    1171             (send layout :add-text-container container)
    1172             (let* ((tv (send (make-objc-instance 'hemlock-text-view
    1173                                                  :with-frame tv-frame
    1174                                                  :text-container container)
    1175                              'autorelease)))
    1176               (send layout :set-delegate tv)
    1177               (send tv :set-min-size (ns-make-size
    1178                                       +cgfloat-zero+
    1179                                       (pref contentsize :<NSS>ize.height)))
    1180               (send tv :set-max-size (ns-make-size large-number-for-text large-number-for-text))
    1181               (send tv :set-rich-text nil)
    1182               (send tv :set-horizontally-resizable t)
    1183               (send tv :set-vertically-resizable t)
    1184               (send tv :set-autoresizing-mask #$NSViewWidthSizable)
    1185               (send tv :set-background-color color)
    1186               (send tv :set-smart-insert-delete-enabled nil)
    1187               (send container :set-width-tracks-text-view tracks-width)
    1188               (send container :set-height-tracks-text-view nil)
    1189               (send scrollview :set-document-view tv)         
    1190               (values tv scrollview))))))))
     1118  (let* ((scrollview (#/autorelease
     1119                      (make-instance
     1120                       'modeline-scroll-view
     1121                       :with-frame (ns:make-ns-rect x y width height)))))
     1122    (#/setBorderType: scrollview #$NSBezelBorder)
     1123    (#/setHasVerticalScroller: scrollview t)
     1124    (#/setHasHorizontalScroller: scrollview t)
     1125    (#/setRulersVisible: scrollview nil)
     1126    (#/setAutoresizingMask: scrollview (logior
     1127                                        #$NSViewWidthSizable
     1128                                        #$NSViewHeightSizable))
     1129    (#/setAutoresizesSubviews: (#/contentView scrollview) t)
     1130    (let* ((layout (make-instance 'ns:ns-layout-manager)))
     1131      (#/addLayoutManager: textstorage layout)
     1132      (#/release layout)
     1133      (let* ((contentsize (#/contentSize scrollview)))
     1134        (ns:with-ns-size (containersize large-number-for-text large-number-for-text)
     1135          (ns:with-ns-rect (tv-frame 0 0 (ns:ns-size-width contentsize) (ns:ns-size-height contentsize))
     1136            (ns:init-ns-size containersize large-number-for-text large-number-for-text)
     1137            (ns:init-ns-rect tv-frame 0 0 (ns:ns-size-width contentsize) (ns:ns-size-height contentsize))
     1138            (let* ((container (#/autorelease (make-instance
     1139                                              'ns:ns-text-container
     1140                                              :with-container-size containersize))))
     1141              (#/addTextContainer: layout  container)
     1142              (let* ((tv (#/autorelease (make-instance 'hemlock-text-view
     1143                                                       :with-frame tv-frame
     1144                                                       :text-container container))))
     1145                (#/setDelegate: layout tv)
     1146                (#/setMinSize: tv (ns:make-ns-size 0 (ns:ns-size-height contentsize)))
     1147                (#/setMaxSize: tv (ns:make-ns-size large-number-for-text large-number-for-text))
     1148                (#/setRichText: tv nil)
     1149                (#/setHorizontallyResizable: tv t)
     1150                (#/setVerticallyResizable: tv t)
     1151                (#/setAutoresizingMask: tv #$NSViewWidthSizable)
     1152                (#/setBackgroundColor: tv color)
     1153                (#/setSmartInsertDeleteEnabled: tv nil)
     1154                (#/setWidthTracksTextView: container tracks-width)
     1155                (#/setHeightTracksTextView: container nil)
     1156                (#/setDocumentView: scrollview tv)           
     1157                (values tv scrollview)))))))))
    11911158
    11921159(defun make-scrolling-textview-for-pane (pane textstorage track-width color)
    1193   (slet ((contentrect (send (send pane 'content-view) 'frame)))
     1160  (let* ((contentrect (#/frame (#/contentView pane))))
    11941161    (multiple-value-bind (tv scrollview)
    11951162        (make-scrolling-text-view-for-textstorage
    11961163         textstorage
    1197          (pref contentrect :<NSR>ect.origin.x)
    1198          (pref contentrect :<NSR>ect.origin.y)
    1199          (pref contentrect :<NSR>ect.size.width)
    1200          (pref contentrect :<NSR>ect.size.height)
     1164         (ns:ns-rect-x contentrect)
     1165         (ns:ns-rect-y contentrect)
     1166         (ns:ns-rect-width contentrect)
     1167         (ns:ns-rect-height contentrect)
    12011168         track-width
    12021169         color)
    1203       (send pane :set-content-view scrollview)
     1170      (#/setContentView: pane scrollview)
    12041171      (setf (slot-value pane 'scroll-view) scrollview
    12051172            (slot-value pane 'text-view) tv
     
    12131180
    12141181(defmethod hi::activate-hemlock-view ((view text-pane))
    1215   (let* ((hemlock-frame (send view 'window))
     1182  (let* ((the-hemlock-frame (#/window view))
    12161183         (text-view (text-pane-text-view view)))
    1217     (send hemlock-frame :make-first-responder text-view)))
     1184    (#/makeFirstResponder: the-hemlock-frame text-view)))
    12181185
    12191186
     
    12231190
    12241191(defmethod hi::activate-hemlock-view ((view echo-area-view))
    1225   (let* ((hemlock-frame (send view 'window)))
     1192  (let* ((the-hemlock-frame (#/window view)))
    12261193    #+debug
    12271194    (#_NSLog #@"Activating echo area")
    1228     (send hemlock-frame :make-first-responder view)))
     1195    (#/makeFirstResponder: the-hemlock-frame view)))
    12291196
    12301197(defmethod text-view-buffer ((self echo-area-view))
    1231   (buffer-cache-buffer (hemlock-buffer-string-cache (send (send self 'text-storage) 'string))))
     1198  (buffer-cache-buffer (hemlock-buffer-string-cache (#/string (#/textStorage self)))))
    12321199
    12331200;;; The "document" for an echo-area isn't a real NSDocument.
     
    12521219(defloadvar *hemlock-frame-count* 0)
    12531220
    1254 (defun make-echo-area (hemlock-frame x y width height gap-context color)
    1255   (slet ((frame (ns-make-rect (float x +cgfloat-zero+)
    1256                               (float y +cgfloat-zero+)
    1257                               (float width +cgfloat-zero+)
    1258                               (float height +cgfloat-zero+))))
    1259     (let* ((box (make-objc-instance "NSView"
    1260                                     :with-frame frame)))
    1261       (send box :set-autoresizing-mask #$NSViewWidthSizable)
    1262       (slet* ((box-frame (send box 'bounds))
    1263               (containersize (ns-make-size large-number-for-text (pref box-frame :<NSR>ect.size.height))))
    1264         (let* ((clipview (make-objc-instance "NSClipView"
    1265                                              :with-frame box-frame)))
    1266           (send clipview :set-autoresizing-mask (logior #$NSViewWidthSizable
    1267                                                         #$NSViewHeightSizable))
    1268           (send clipview :set-background-color color)
    1269           (send box :add-subview clipview)
    1270           (send box :set-autoresizes-subviews t)
    1271           (send clipview 'release)
    1272           (let* ((buffer (hi:make-buffer (format nil "Echo Area ~d"
    1273                                                  (prog1
    1274                                                      *hemlock-frame-count*
    1275                                                    (incf *hemlock-frame-count*)))
    1276                                          :modes '("Echo Area")))
    1277                  (textstorage
    1278                   (progn
    1279                     (setf (hi::buffer-gap-context buffer) gap-context)
    1280                     (make-textstorage-for-hemlock-buffer buffer)))
    1281                  (doc (make-objc-instance 'echo-area-document))
    1282                  (layout (make-objc-instance 'ns-layout-manager))
    1283                  (container (send (make-objc-instance 'ns-text-container
    1284                                                       :with-container-size
    1285                                                       containersize)
    1286                                   'autorelease)))
    1287             (send textstorage :add-layout-manager layout)
    1288             (send layout :add-text-container container)
    1289             (send layout 'release)
    1290             (let* ((echo (make-objc-instance 'echo-area-view
    1291                                              :with-frame box-frame
    1292                                              :text-container container)))
    1293               (send echo :set-min-size (pref box-frame :<NSR>ect.size))
    1294               (send echo :set-max-size (ns-make-size large-number-for-text (pref box-frame :<NSR>ect.size)))
    1295               (send echo :set-rich-text nil)
    1296               (send echo :set-horizontally-resizable t)
    1297               (send echo :set-vertically-resizable nil)
    1298               (send echo :set-autoresizing-mask #$NSViewNotSizable)
    1299               (send echo :set-background-color color)
    1300               (send container :set-width-tracks-text-view nil)
    1301               (send container :set-height-tracks-text-view nil)
    1302               (setf (hemlock-frame-echo-area-buffer hemlock-frame) buffer
    1303                     (slot-value doc 'textstorage) textstorage
    1304                     (hi::buffer-document buffer) doc)
    1305               (send clipview :set-document-view echo)
    1306               (send clipview :set-autoresizes-subviews nil)
    1307               (send echo 'size-to-fit)
    1308               (values echo box))))))))
     1221(defun make-echo-area (the-hemlock-frame x y width height gap-context color)
     1222  (let* ((box (make-instance 'ns:ns-view :with-frame (ns:make-ns-rect x y width height))))
     1223    (#/setAutoresizingMask: box #$NSViewWidthSizable)
     1224    (let* ((box-frame (#/bounds box))
     1225           (containersize (ns:make-ns-size large-number-for-text (ns:ns-rect-height box-frame)))
     1226           (clipview (make-instance 'ns:ns-clip-view
     1227                                    :with-frame box-frame)))
     1228      (#/setAutoresizingMask: clipview (logior #$NSViewWidthSizable
     1229                                               #$NSViewHeightSizable))
     1230      (#/setBackgroundColor: clipview color)
     1231      (#/addSubview: box clipview)
     1232      (#/setAutoresizesSubviews: box t)
     1233      (#/release clipview)
     1234      (let* ((buffer (hi:make-buffer (format nil "Echo Area ~d"
     1235                                             (prog1
     1236                                                 *hemlock-frame-count*
     1237                                               (incf *hemlock-frame-count*)))
     1238                                     :modes '("Echo Area")))
     1239             (textstorage
     1240              (progn
     1241                (setf (hi::buffer-gap-context buffer) gap-context)
     1242                (make-textstorage-for-hemlock-buffer buffer)))
     1243             (doc (make-instance 'echo-area-document))
     1244             (layout (make-instance 'ns:ns-layout-manager))
     1245             (container (#/autorelease
     1246                         (make-instance 'ns:ns-text-container
     1247                                        :with-container-size
     1248                                        containersize))))
     1249        (#/addLayoutManager: textstorage layout)
     1250        (#/addTextContainer: layout container)
     1251        (#/release layout)
     1252        (let* ((echo (make-instance 'echo-area-view
     1253                                    :with-frame box-frame
     1254                                    :text-container container)))
     1255          (#/setMinSize: echo (pref box-frame :<NSR>ect.size))
     1256          (#/setMaxSize: echo (ns:make-ns-size large-number-for-text large-number-for-text))
     1257          (#/setRichText: echo nil)
     1258          (#/setHorizontallyResizable: echo t)
     1259          (#/setVerticallyResizable: echo nil)
     1260          (#/setAutoresizingMask: echo #$NSViewNotSizable)
     1261          (#/setBackgroundColor: echo color)
     1262          (#/setWidthTracksTextView: container nil)
     1263          (#/setHeightTracksTextView: container nil)
     1264          (setf (hemlock-frame-echo-area-buffer the-hemlock-frame) buffer
     1265                (slot-value doc 'textstorage) textstorage
     1266                (hi::buffer-document buffer) doc)
     1267          (#/setDocumentView: clipview echo)
     1268          (#/setAutoresizesSubviews: clipview nil)
     1269          (#/sizeToFit echo)
     1270          (values echo box))))))
    13091271                   
    13101272(defun make-echo-area-for-window (w gap-context-for-echo-area-buffer color)
    1311   (let* ((content-view (send w 'content-view)))
    1312     (slet ((bounds (send content-view 'bounds)))
     1273  (let* ((content-view (#/contentView w))
     1274         (bounds (#/bounds content-view)))
    13131275      (multiple-value-bind (echo-area box)
    13141276          (make-echo-area w
    13151277                          0.0f0
    13161278                          0.0f0
    1317                           (- (pref bounds :<NSR>ect.size.width) 24.0f0)
     1279                          (- (ns:ns-rect-width bounds) 24.0f0)
    13181280                          20.0f0
    13191281                          gap-context-for-echo-area-buffer
    13201282                          color)
    1321         (send content-view :add-subview box)
    1322         echo-area))))
     1283        (#/addSubview: content-view box)
     1284        echo-area)))
    13231285               
    13241286(defclass hemlock-frame (ns:ns-window)
     
    13431305  (%make-nsstring (double-%-in (princ-to-string cond))))
    13441306
    1345 (define-objc-method ((:void :run-error-sheet info) hemlock-frame)
    1346   (let* ((message (send info :object-at-index 0))
    1347          (signal (send info :object-at-index 1)))
     1307(objc:defmethod (#/runErrorSheet: :void) ((self hemlock-frame) info)
     1308  (let* ((message (#/objectAtIndex: info 0))
     1309         (signal (#/objectAtIndex: info 1)))
    13481310    (#_NSBeginAlertSheet #@"Error in Hemlock command processing" ;title
    13491311                         (if (logbitp 0 (random 2))
    13501312                           #@"Not OK, but what can you do?"
    13511313                           #@"The sky is falling. FRED never did this!")
    1352                          (%null-ptr)
    1353                          (%null-ptr)
     1314                         +null-ptr+
     1315                         +null-ptr+
    13541316                         self
    13551317                         self
    1356                          (@selector "sheetDidEnd:returnCode:contextInfo:")
    1357                          (@selector "sheetDidDismiss:returnCode:contextInfo:")
     1318                         (@selector #/sheetDidEnd:returnCode:contextInfo:)
     1319                         (@selector #/sheetDidDismiss:returnCode:contextInfo:)
    13581320                         signal
    13591321                         message)))
    13601322
    1361 (define-objc-method ((:void :sheet-did-end sheet
    1362                             :return-code code
    1363                             :context-info info)
    1364                      hemlock-frame)
     1323(objc:defmethod (#/sheetDidEnd:returnCode:contextInfo: :void) ((self hemlock-frame))
    13651324 (declare (ignore sheet code info)))
    13661325
    1367 (define-objc-method ((:void :sheet-did-dismiss sheet
    1368                             :return-code code
    1369                             :context-info info)
    1370                      hemlock-frame)
     1326(objc:defmethod (#/sheetDidDismiss:returnCode:contextInfo: :void)
     1327    ((self hemlock-frame) sheet code info)
    13711328  (declare (ignore sheet code))
    1372   (ccl::%signal-semaphore-ptr (%int-to-ptr (send info 'unsigned-int-value))))
     1329  (ccl::%signal-semaphore-ptr (%int-to-ptr (#/unsignedLongValue info))))
    13731330 
    13741331(defun report-condition-in-hemlock-frame (condition frame)
    13751332  (let* ((semaphore (make-semaphore))
    13761333         (message (nsstring-for-lisp-condition condition))
    1377          (sem-value (make-objc-instance 'ns:ns-number
    1378                                         :with-unsigned-int (%ptr-to-int (semaphore.value semaphore)))))
     1334         (sem-value (make-instance 'ns:ns-number
     1335                                   :with-unsigned-long (%ptr-to-int (semaphore.value semaphore)))))
    13791336    (%stack-block ((paramptrs (ash 2 target::word-shift)))
    13801337      (setf (%get-ptr paramptrs 0) message
    13811338            (%get-ptr paramptrs (ash 1 target::word-shift)) sem-value)
    1382       (let* ((params (make-objc-instance 'ns:ns-array
    1383                                          :with-objects paramptrs
    1384                                          :count 2))
     1339      (let* ((params (make-instance 'ns:ns-array
     1340                                    :with-objects paramptrs
     1341                                    :count 2))
    13851342             (*debug-io* *typeout-stream*))
    13861343        (stream-clear-output *debug-io*)
    13871344        (print-call-history :detailed-p nil)
    1388         (send frame
    1389               :perform-selector-on-main-thread
    1390               (@selector "runErrorSheet:")
    1391               :with-object params
    1392               :wait-until-done t)
     1345        (#/performSelectorOnMainThread:withObject:waitUntilDone:
     1346         frame (@selector #/runErrorSheet:) params t)
    13931347        (wait-on-semaphore semaphore)))))
    13941348
    13951349(defun hi::report-hemlock-error (condition)
    1396   (report-condition-in-hemlock-frame condition (send (hi::current-window) 'window)))
     1350  (report-condition-in-hemlock-frame condition (#/window (hi::current-window))))
    13971351                       
    13981352                       
     
    14391393
    14401394
    1441 (define-objc-method ((:void close) hemlock-frame)
    1442   (let* ((content-view (send self 'content-view))
    1443          (subviews (send content-view 'subviews)))
    1444     (do* ((i (1- (send subviews 'count)) (1- i)))
     1395(objc:defmethod (#/close :void) ((self hemlock-frame))
     1396  (let* ((content-view (#/contentView self))
     1397         (subviews (#/subviews content-view)))
     1398    (do* ((i (1- (#/count subviews)) (1- i)))
    14451399         ((< i 0))
    1446       (send (send subviews :object-at-index i)
    1447             'remove-from-superview-without-needing-display)))
     1400      (#/removeFromSuperviewWithoutNeedingDisplay (#/objectAtIndex: subviews i))))
    14481401  (let* ((proc (slot-value self 'command-thread)))
    14491402    (when proc
     
    14541407    (when echo-doc
    14551408      (setf (hemlock-frame-echo-area-buffer self) nil)
    1456       (send echo-doc 'close)))
     1409      (#/close echo-doc)))
    14571410  (release-canonical-nsobject self)
    1458   (send-super 'close))
     1411  (call-next-method))
    14591412 
    14601413(defun new-hemlock-document-window ()
    1461   (let* ((w (new-cocoa-window :class (find-class 'hemlock-frame)
     1414  (let* ((w (new-cocoa-window :class hemlock-frame
    14621415                              :activate nil)))
    14631416      (values w (add-pane-to-window w :reserve-below 20.0))))
     
    14661419
    14671420(defun add-pane-to-window (w &key (reserve-above 0.0f0) (reserve-below 0.0f0))
    1468   (let* ((window-content-view (send w 'content-view)))
    1469     (slet ((window-frame (send window-content-view 'frame)))
    1470       (slet ((pane-rect (ns-make-rect +cgfloat-zero+
    1471                                       (float reserve-below +cgfloat-zero+)
    1472                                       (pref window-frame :<NSR>ect.size.width)
    1473                                       (- (pref window-frame :<NSR>ect.size.height) (+ reserve-above reserve-below)))))
    1474         (let* ((pane (make-objc-instance 'text-pane :with-frame pane-rect)))
    1475           (send window-content-view :add-subview pane)
    1476           pane)))))
    1477 
    1478                                        
    1479                                      
     1421  (let* ((window-content-view (#/contentView w))
     1422         (window-frame (#/frame window-content-view)))
     1423    (ns:with-ns-rect (pane-rect  0 reserve-below (ns:ns-rect-width window-frame) (- (ns:ns-rect-height window-frame) (+ reserve-above reserve-below)))
     1424      (let* ((pane (make-instance 'text-pane :with-frame pane-rect)))
     1425        (#/addSubview: window-content-view pane)
     1426        pane))))
     1427
    14801428(defun textpane-for-textstorage (ts ncols nrows container-tracks-text-view-width color)
    14811429  (let* ((pane (nth-value
     
    14971445(defun %nsstring-to-mark (nsstring mark)
    14981446  "returns external-format of string"
    1499   (let* ((string-len (send (the ns:ns-string nsstring) 'length))
     1447  (let* ((string-len (#/length nsstring))
    15001448         (line-start 0)
    15011449         (first-line-terminator ())
     
    15081456           (setf (hi::buffer-gap-context buffer)
    15091457                 (hi::make-buffer-gap-context)))))
    1510     (slet ((remaining-range (ns-make-range 0 1)))
    1511           (rlet ((line-end-index :unsigned)
    1512                  (contents-end-index :unsigned))
    1513             (do* ((number (+ (hi::line-number first-line) hi::line-increment)
    1514                           (+ number hi::line-increment)))
    1515                  ((= line-start string-len)
    1516                   (let* ((line (hi::mark-line mark)))
    1517                     (hi::insert-string mark (make-string 0))
    1518                     (setf (hi::line-next previous) line
    1519                           (hi::line-previous line) previous))
    1520                   nil)
    1521               (setf (pref remaining-range :<NSR>ange.location) line-start)
    1522               (send nsstring
    1523                     :get-line-start (%null-ptr)
    1524                     :end line-end-index
    1525                     :contents-end contents-end-index
    1526                     :for-range remaining-range)
    1527               (let* ((contents-end (pref contents-end-index :unsigned))
    1528                      (line-end (pref line-end-index :unsigned))
    1529                      (chars (make-string (- contents-end line-start))))
    1530                 (do* ((i line-start (1+ i))
    1531                       (j 0 (1+ j)))
    1532                      ((= i contents-end))
    1533                   (setf (schar chars j) (code-char (send nsstring :character-at-index i))))
    1534                 (unless first-line-terminator
    1535                   (let* ((terminator (code-char
    1536                                       (send nsstring :character-at-index
    1537                                             contents-end))))
    1538                     (setq first-line-terminator
    1539                           (case terminator
    1540                             (#\return (if (= line-end (+ contents-end 2))
    1541                                         :cp/m
    1542                                         :macos))
    1543                             (t :unix)))))
    1544                 (if (eq previous first-line)
    1545                   (progn
    1546                     (hi::insert-string mark chars)
    1547                     (hi::insert-character mark #\newline)
    1548                     (setq first-line nil))
    1549                   (if (eq string-len contents-end)
    1550                     (hi::insert-string mark chars)
    1551                     (let* ((line (hi::make-line
    1552                                   :previous previous
    1553                                   :%buffer buffer
    1554                                   :chars chars
    1555                                   :number number)))
    1556                       (setf (hi::line-next previous) line)
    1557                       (setq previous line))))
    1558                 (setq line-start line-end)))))
     1458    (rlet ((remaining-range :ns-range :location 0 :length  1)
     1459           (line-end-index :<NSUI>nteger)
     1460           (contents-end-index :<NSUI>nteger))
     1461      (do* ((number (+ (hi::line-number first-line) hi::line-increment)
     1462                    (+ number hi::line-increment)))
     1463           ((= line-start string-len)
     1464            (let* ((line (hi::mark-line mark)))
     1465              (hi::insert-string mark (make-string 0))
     1466              (setf (hi::line-next previous) line
     1467                    (hi::line-previous line) previous))
     1468            nil)
     1469        (setf (pref remaining-range :<NSR>ange.location) line-start)
     1470        (#/getLineStart:end:contentsEnd:forRange:
     1471         nsstring
     1472         +null-ptr+
     1473         line-end-index
     1474         contents-end-index
     1475         remaining-range)
     1476        (let* ((contents-end (pref contents-end-index :<NSUI>nteger))
     1477               (line-end (pref line-end-index :<NSUI>nteger))
     1478               (chars (make-string (- contents-end line-start))))
     1479          (do* ((i line-start (1+ i))
     1480                (j 0 (1+ j)))
     1481               ((= i contents-end))
     1482            (setf (schar chars j) (code-char (#/characterAtIndex: nsstring i))))
     1483          (unless first-line-terminator
     1484            (let* ((terminator (code-char
     1485                                (#/characterAtIndex: nsstring contents-end))))
     1486              (setq first-line-terminator
     1487                    (case terminator
     1488                      (#\return (if (= line-end (+ contents-end 2))
     1489                                  :cp/m
     1490                                  :macos))
     1491                      (t :unix)))))
     1492          (if (eq previous first-line)
     1493            (progn
     1494              (hi::insert-string mark chars)
     1495              (hi::insert-character mark #\newline)
     1496              (setq first-line nil))
     1497            (if (eq string-len contents-end)
     1498              (hi::insert-string mark chars)
     1499              (let* ((line (hi::make-line
     1500                            :previous previous
     1501                            :%buffer buffer
     1502                            :chars chars
     1503                            :number number)))
     1504                (setf (hi::line-next previous) line)
     1505                (setq previous line))))
     1506          (setq line-start line-end))))
    15591507    first-line-terminator))
    15601508 
     
    15831531         (cocoa-pathname (%make-nsstring lisp-namestring))
    15841532         (hi::*buffer-gap-context* (hi::buffer-gap-context buffer))
    1585          (data (make-objc-instance 'ns:ns-data
    1586                                    :with-contents-of-file cocoa-pathname))
    1587          (string (make-objc-instance 'ns:ns-string
    1588                                      :with-data data
    1589                                      :encoding #$NSASCIIStringEncoding))
     1533         (data (make-instance 'ns:ns-data
     1534                              :with-contents-of-file cocoa-pathname))
     1535         (string (make-instance 'ns:ns-string
     1536                                :with-data data
     1537                                :encoding #$NSASCIIStringEncoding))
    15901538         (external-format (%nsstring-to-mark string mark)))
    15911539    (unless (hi::buffer-external-format buffer)
     
    16041552(defun %hemlock-frame-for-textstorage (ts ncols nrows container-tracks-text-view-width color)
    16051553  (let* ((pane (textpane-for-textstorage ts ncols nrows container-tracks-text-view-width color))
    1606          (frame (send pane 'window))
     1554         (frame (#/window pane))
    16071555         (buffer (text-view-buffer (text-pane-text-view pane))))
    16081556    (setf (slot-value frame 'echo-area-view)
     
    16371585(defun hi::document-begin-editing (document)
    16381586  #-all-in-cocoa-thread
    1639   (send (slot-value document 'textstorage) 'begin-editing)
     1587  (#/beginEditing (slot-value document 'textstorage))
    16401588  #+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))
     1589  (#/performSelectorOnMainThread:withObject:waitUntilDone:
     1590   (slot-value document 'textstorage)
     1591   (@selector #/beginEditing)
     1592   +null-ptr+
     1593   t))
    16461594
    16471595(defun document-edit-level (document)
    16481596  (slot-value (slot-value document 'textstorage) 'edit-count))
    16491597
    1650 
    1651 
    16521598(defun hi::document-end-editing (document)
    16531599  #-all-in-cocoa-thread
    1654   (send (slot-value document 'textstorage) 'end-editing)
     1600  (#/endEditing (slot-value document 'textstorage))
    16551601  #+all-in-cocoa-thread
    1656   (send (slot-value document 'textstorage)
    1657         :perform-selector-on-main-thread
    1658         (@selector "endEditing")
    1659         :with-object (%null-ptr)
    1660         :wait-until-done t))
     1602  (#/performSelectorOnMainThread:withObject:waitUntilDone:
     1603   (slot-value document 'textstorage)
     1604   (@selector #/endEditing)
     1605   +null-ptr+
     1606   t))
    16611607
    16621608(defun hi::document-set-point-position (document)
     
    16651611  (#_NSLog #@"Document set point position called")
    16661612  (let* ((textstorage (slot-value document 'textstorage)))
    1667     (send textstorage
    1668           :perform-selector-on-main-thread
    1669           (@selector "updateHemlockSelection")
    1670           :with-object (%null-ptr)
    1671           :wait-until-done t)))
     1613    (#/performSelectorOnMainThread:withObject:waitUntilDone:
     1614     textstorage (@selector #/updateHemlockSelection) +null-ptr+ t)))
    16721615
    16731616
     
    16751618(defun perform-edit-change-notification (textstorage selector pos n)
    16761619  (let* ((number-for-pos
    1677           (send (send (@class "NSNumber") 'alloc)
    1678                 :init-with-int pos))
    1679          (number-for-n
    1680           (send (send (@class "NSNumber") 'alloc)
    1681                 :init-with-int n)))
    1682     (%stack-block ((paramptrs (ash 2 target::word-shift)))
    1683       (setf (%get-ptr paramptrs 0) number-for-pos
    1684             (%get-ptr paramptrs (ash 1 target::word-shift))
    1685             number-for-n)
    1686       (let* ((params
    1687               (send (send (@class "NSArray") 'alloc)
    1688                     :init-with-objects paramptrs
    1689                     :count 2)))
    1690         (send textstorage
    1691                     :perform-selector-on-main-thread
    1692                     selector
    1693                     :with-object params
    1694                     :wait-until-done t)
    1695               (send params 'release)
    1696               (send number-for-pos 'release)
    1697               (send number-for-n 'release)))))
     1620          (#/initWithLong: (#/alloc ns:ns-number) pos))
     1621         (number-for-n
     1622          (#/initWithLong: (#/alloc ns:ns-number) n)))
     1623    (rlet ((paramptrs (:array :id 2)))
     1624      (setf (paref paramptrs (:* :id) 0) number-for-pos
     1625            (paref paramptrs (:* :id) 1) number-for-n)
     1626      (let* ((params (#/initWithObjects:count: (#/alloc ns:ns-array) paramptrs 2)))
     1627        (#/performSelectorOnMainThread:withObject:waitUntilDone:
     1628         textstorage selector params  t)
     1629        (#/release params)
     1630        (#/release number-for-n)
     1631        (#/release number-for-pos)))))
    16981632
    16991633(defun textstorage-note-insertion-at-position (textstorage pos n)
    17001634  #+debug
    17011635  (#_NSLog #@"insertion at position %d, len %d" :int pos :int n)
    1702   (send textstorage
    1703         :edited #$NSTextStorageEditedAttributes
    1704         :range (ns-make-range pos 0)
    1705         :change-in-length n)
    1706   (send textstorage
    1707         :edited #$NSTextStorageEditedCharacters
    1708         :range (ns-make-range pos n)
    1709         :change-in-length 0))
    1710 
    1711 
     1636  (rlet ((range ns:ns-range :location pos :length 0))
     1637    (#/edited:range:changeInLength:
     1638     textstorage #$NSTextStorageEditedAttributes range n)
     1639    (setf (ns:ns-range-length range) n)
     1640    (#/edited:range:changeInLength:
     1641     textstorage  #$NSTextStorageEditedCharacters range 0)))
    17121642
    17131643
     
    17191649           (n (- (mark-absolute-position (hi::region-end region)) pos)))
    17201650      (perform-edit-change-notification textstorage
    1721                                         (@selector "noteAttrChange:")
     1651                                        (@selector #/noteAttrChange:)
    17221652                                        pos
    17231653                                        n))))
     
    17331663          #+debug
    17341664          (format t "~&insert: pos = ~d, n = ~d" pos n)
    1735           (let* ((display (hemlock-buffer-string-cache (send textstorage 'string))))
     1665          (let* ((display (hemlock-buffer-string-cache (#/string textstorage))))
    17361666            ;(reset-buffer-cache display)
    17371667            (adjust-buffer-cache-for-insertion display pos n)
     
    17551685                 :int n)
    17561686        #-all-in-cocoa-thread
    1757         (send textstorage
    1758           :edited (logior #$NSTextStorageEditedCharacters
     1687        (rlet ((range :ns-range) :location (mark-absolute-position mark) :length n)
     1688          (#/edited:range:changeInLength:
     1689           textstorage
     1690           (logior #$NSTextStorageEditedCharacters
    17591691                          #$NSTextStorageEditedAttributes)
    1760           :range (ns-make-range (mark-absolute-position mark) n)
    1761           :change-in-length 0)
     1692           range
     1693           0))
    17621694        #+all-in-cocoa-thread
    17631695        (perform-edit-change-notification textstorage
    1764                                           (@selector "noteModification:")
     1696                                          (@selector #/noteModification:)
    17651697                                          (mark-absolute-position mark)
    17661698                                          n)))))
     
    17741706        #-all-in-cocoa-thread
    17751707        (let* ((pos (mark-absolute-position mark)))
    1776           (send textstorage
    1777           :edited #$NSTextStorageEditedCharacters
    1778           :range (ns-make-range pos n)
    1779           :change-in-length (- n))
    1780           (let* ((display (hemlock-buffer-string-cache (send textstorage 'string))))
     1708          (rlet ((range :ns-range :location pos :length n))
     1709          (#/edited:range:changeInLength:
     1710           textstorage #$NSTextStorageEditedCharacters range (- n)))
     1711          (let* ((display (hemlock-buffer-string-cache (#/string textstorage))))
    17811712            (reset-buffer-cache display)
    17821713            (update-line-cache-for-index display pos)))
    17831714        #+all-in-cocoa-thread
    17841715        (perform-edit-change-notification textstorage
    1785                                           (@selector "noteDeletion:")
     1716                                          (@selector #/noteDeletion:)
    17861717                                          (mark-absolute-position mark)
    17871718                                          (abs n))))))
    17881719
    17891720(defun hi::set-document-modified (document flag)
    1790   (send document
    1791         :update-change-count (if flag #$NSChangeDone #$NSChangeCleared)))
     1721  (#/updateChangeCount: document (if flag #$NSChangeDone #$NSChangeCleared)))
    17921722
    17931723
     
    18001730
    18011731(defun size-of-char-in-font (f)
    1802   (let* ((sf (send f 'screen-font)))
    1803     (if (%null-ptr-p sf) (setq sf f))
    1804     (values (fround
    1805              (+ (- (send sf 'ascender)
    1806                    (send sf 'descender))
    1807                 (send sf 'leading)))
    1808             (slet ((s (send sf 'maximum-advancement)))
    1809               (fround (pref s :<NSS>ize.width))))))
     1732  (let* ((sf (#/screenFont f))
     1733         (screen-p t))
     1734    (if (%null-ptr-p sf) (setq sf f screen-p nil))
     1735    (let* ((layout (#/autorelease (#/init (#/alloc ns:ns-layout-manager)))))
     1736      (#/setUsesScreenFonts: layout screen-p)
     1737      (values (fround (#/defaultLineHeightForFont: layout sf))
     1738              (fround (ns:ns-size-width (#/advancementForGlyph: sf (#/glyphWithName: sf #@" "))))))))
    18101739         
    18111740
     
    18161745         (width (fceiling (* ncols char-width)))
    18171746         (scrollview (text-pane-scroll-view pane))
    1818          (window (send scrollview 'window))
    1819          (has-horizontal-scroller (send scrollview 'has-horizontal-scroller))
    1820          (has-vertical-scroller (send scrollview 'has-vertical-scroller)))
    1821     (rlet ((tv-size :<NSS>ize :height height
    1822                     :width (+ width (* 2 (send (send tv 'text-container)
    1823                                                'line-fragment-padding)))))
     1747         (window (#/window scrollview))
     1748         (has-horizontal-scroller (#/hasHorizontalScroller scrollview))
     1749         (has-vertical-scroller (#/hasVerticalScroller scrollview)))
     1750    (ns:with-ns-size (tv-size
     1751                      (+ width (* 2 (#/lineFragmentPadding (#/textContainer tv))))
     1752                      height)
    18241753      (when has-vertical-scroller
    1825         (send scrollview :set-vertical-line-scroll char-height)
    1826         (send scrollview :set-vertical-page-scroll +cgfloat-zero+ #|char-height|#))
     1754        (#/setVerticalLineScroll: scrollview char-height)
     1755        (#/setVerticalPageScroll: scrollview +cgfloat-zero+ #|char-height|#))
    18271756      (when has-horizontal-scroller
    1828         (send scrollview :set-horizontal-line-scroll char-width)
    1829         (send scrollview :set-horizontal-page-scroll +cgfloat-zero+ #|char-width|#))
    1830       (slet ((sv-size
    1831               (send (@class ns-scroll-view)
    1832                     :frame-size-for-content-size tv-size
    1833                     :has-horizontal-scroller has-horizontal-scroller
    1834                     :has-vertical-scroller has-vertical-scroller
    1835                     :border-type (send scrollview 'border-type))))
    1836         (slet ((pane-frame (send pane 'frame))
    1837                (margins (send pane 'content-view-margins)))
    1838           (incf (pref sv-size :<NSS>ize.height)
    1839                 (+ (pref pane-frame :<NSR>ect.origin.y)
    1840                    (* 2 (pref margins :<NSS>ize.height))))
    1841           (incf (pref sv-size :<NSS>ize.width)
    1842                 (pref margins :<NSS>ize.width))
    1843           (send window :set-content-size sv-size)
    1844           (send window :set-resize-increments
    1845                 (ns-make-size char-width char-height)))))))
     1757        (#/setHorizontalLineScroll: scrollview char-width)
     1758        (#/setHorizontalPageScroll: scrollview +cgfloat-zero+ #|char-width|#))
     1759      (let* ((sv-size (#/frameSizeForContentSize:hasHorizontalScroller:hasVerticalScroller:borderType: ns:ns-scroll-view tv-size has-horizontal-scroller has-vertical-scroller (#/borderType scrollview)))
     1760             (pane-frame (#/frame pane))
     1761             (margins (#/contentViewMargins pane)))
     1762        (incf (ns:ns-size-height sv-size)
     1763              (+ (ns:ns-rect-y pane-frame)
     1764                 (* 2 (ns:ns-size-height  margins))))
     1765        (incf (ns:ns-size-width sv-size)
     1766              (ns:ns-size-width margins))
     1767        (#/setContentSize: window sv-size)
     1768        (#/setResizeIncrements: window
     1769                                (ns:make-ns-size char-width char-height))))))
    18461770                                   
    18471771 
     
    18521776
    18531777
    1854 (define-objc-method ((:void :_window-will-close notification)
    1855                      hemlock-editor-window-controller)
    1856   #+debug
    1857   (let* ((w (send notification 'object)))
    1858     (#_NSLog #@"Window controller: window will close: %@" :id w))
    1859   (send-super :_window-will-close notification))
    1860 
    18611778;;; The HemlockEditorDocument class.
    18621779
     
    18671784
    18681785(defmethod textview-background-color ((doc hemlock-editor-document))
    1869   (send (find-class 'ns:ns-color)
    1870         :color-with-calibrated-red (float *editor-background-red-component*
    1871                                           +cgfloat-zero+)
    1872         :green (float *editor-background-green-component* +cgfloat-zero+)
    1873         :blue (float *editor-background-blue-component* +cgfloat-zero+)
    1874         :alpha (float *editor-background-alpha-component* +cgfloat-zero+)))
    1875 
    1876 
    1877 (define-objc-method ((:void :set-text-storage ts)
    1878                      hemlock-editor-document)
    1879   (let* ((doc (%inc-ptr self 0))
    1880          (string (send ts 'string))
     1786  (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color
     1787                                              (float *editor-background-red-component*
     1788                                                     +cgfloat-zero+)
     1789                                              (float *editor-background-green-component* +cgfloat-zero+)
     1790                                              (float *editor-background-blue-component* +cgfloat-zero+)
     1791                                              (float *editor-background-alpha-component* +cgfloat-zero+)))
     1792
     1793
     1794(objc:defmethod (#/setTextStorage: :void) ((self hemlock-editor-document) ts)
     1795  (let* ((doc (%inc-ptr self 0))        ; workaround for stack-consed self
     1796         (string (#/string ts))
    18811797         (cache (hemlock-buffer-string-cache string))
    18821798         (buffer (buffer-cache-buffer cache)))
     
    18861802
    18871803;; This runs on the main thread.
    1888 (define-objc-method ((:<BOOL> :revert-to-saved-from-file filename
    1889                               :of-type filetype)
    1890                      hemlock-editor-document)
     1804(objc:defmethod (#/revertToSavedFromFile:ofType: :<BOOL>)
     1805    ((self hemlock-editor-document) filename filetype)
    18911806  (declare (ignore filetype))
    18921807  #+debug
    18931808  (#_NSLog #@"revert to saved from file %@ of type %@"
    18941809           :id filename :id filetype)
    1895   (let* ((data (make-objc-instance 'ns:ns-data
    1896                                    :with-contents-of-file filename))
    1897          (nsstring (make-objc-instance 'ns:ns-string
    1898                                      :with-data data
    1899                                      :encoding #$NSASCIIStringEncoding))
     1810  (let* ((data (make-instance ns:ns-data
     1811                              :with-contents-of-file filename))
     1812         (nsstring (make-instance ns:ns-string
     1813                                  :with-data data
     1814                                  :encoding #$NSASCIIStringEncoding))
    19001815         (buffer (hemlock-document-buffer self))
    19011816         (old-length (hemlock-buffer-length buffer))
     
    19041819         (point (hi::buffer-point buffer))
    19051820         (pointpos (mark-absolute-position point)))
    1906     (send textstorage 'begin-editing)
    1907     (send textstorage
    1908           :edited #$NSTextStorageEditedCharacters
    1909           :range (ns-make-range 0 old-length)
    1910           :change-in-length (- old-length))
     1821    (#/beginEditing textstorage)
     1822    (rlet ((changed :ns-range :location 0 :length old-length))
     1823      (#/edited:range:changeInLength:
     1824       textstorage #$NSTextStorageEditedCharacters changed (- old-length)))
    19111825    (nsstring-to-buffer nsstring buffer)
    1912     (let* ((newlen (hemlock-buffer-length buffer)))
    1913       (send textstorage
    1914             :edited #$NSTextStorageEditedAttributes
    1915             :range (ns-make-range 0 0)
    1916             :change-in-length newlen)
    1917       (send textstorage
    1918             :edited #$NSTextStorageEditedCharacters
    1919             :range (ns-make-range 0 newlen)
    1920             :change-in-length 0)
    1921       (let* ((ts-string (send textstorage 'string))
    1922              (display (hemlock-buffer-string-cache ts-string)))
    1923         (reset-buffer-cache display)
    1924         (update-line-cache-for-index display 0)
    1925         (move-hemlock-mark-to-absolute-position point
    1926                                                 display
    1927                                                 (min newlen pointpos)))
    1928       (send textstorage 'end-editing))
     1826    (rletZ ((new-range :ns-range))
     1827      (let* ((newlen (hemlock-buffer-length buffer)))
     1828        (#/edited:range:changeInLength: textstorage  #$NSTextStorageEditedAttributes new-range newlen)
     1829        (setf (ns:ns-range-length new-range) newlen)
     1830        (#/edited:range:changeInLength: textstorage #$NSTextStorageEditedCharacters new-range 0)
     1831        (let* ((ts-string (#/string textstorage))
     1832               (display (hemlock-buffer-string-cache ts-string)))
     1833          (reset-buffer-cache display)
     1834          (update-line-cache-for-index display 0)
     1835          (move-hemlock-mark-to-absolute-position point
     1836                                                  display
     1837                                                  (min newlen pointpos))))
     1838      (#/endEditing textstorage))
    19291839    (hi::document-set-point-position self)
    19301840    (setf (hi::buffer-modified buffer) nil)
     
    19341844           
    19351845 
    1936 (define-objc-method ((:id init) hemlock-editor-document)
    1937   (let* ((doc (send-super 'init)))
     1846(objc:defmethod #/init ((self hemlock-editor-document))
     1847  (let* ((doc (call-next-method)))
    19381848    (unless  (%null-ptr-p doc)
    1939       (send doc
    1940         :set-text-storage (make-textstorage-for-hemlock-buffer
    1941                            (make-hemlock-buffer
    1942                             (lisp-string-from-nsstring
    1943                              (send doc 'display-name))
    1944                             :modes '("Lisp" "Editor")))))
     1849      (#/setTextStorage: doc (make-textstorage-for-hemlock-buffer
     1850                              (make-hemlock-buffer
     1851                               (lisp-string-from-nsstring
     1852                                (#/displayName doc))
     1853                               :modes '("Lisp" "Editor")))))
    19451854    doc))
    19461855                     
    1947 
    1948 (define-objc-method ((:<BOOL> :read-from-file filename
    1949                               :of-type type)
    1950                      hemlock-editor-document)
     1856(objc:defmethod (#/readFromFile:ofType: :<BOOL>)
     1857    ((self hemlock-editor-document) filename type)
    19511858  (declare (ignorable type))
    19521859  (let* ((pathname (lisp-string-from-nsstring filename))
     
    19601867                    b)))
    19611868         (hi::*buffer-gap-context* (hi::buffer-gap-context buffer))
    1962          (data (make-objc-instance 'ns:ns-data
    1963                                    :with-contents-of-file filename))
    1964          (string (make-objc-instance 'ns:ns-string
    1965                                      :with-data data
    1966                                      :encoding #$NSASCIIStringEncoding)))
     1869         (data (make-instance 'ns:ns-data :with-contents-of-file filename))
     1870         (string (make-instance 'ns:ns-string
     1871                                :with-data data
     1872                                :encoding #$NSASCIIStringEncoding)))
    19671873    (hi::document-begin-editing self)
    19681874    (nsstring-to-buffer string buffer)
    19691875    (let* ((textstorage (slot-value self 'textstorage))
    1970            (display (hemlock-buffer-string-cache (send textstorage 'string))))
     1876           (display (hemlock-buffer-string-cache (#/string textstorage))))
    19711877      (reset-buffer-cache display)
    19721878      (update-line-cache-for-index display 0)
     
    19781884    (setf (hi::buffer-modified buffer) nil)
    19791885    (hi::process-file-options buffer pathname)
    1980     #$YES))
     1886    t))
    19811887
    19821888#+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)
     1889(objc:defmethod (#/writeWithBackupToFile:ofType:saveOperation: :<BOOL>)
     1890    ((self hemlock-editor-document) path type (save-operation :<NSS>ave<O>peration<T>ype))
    19871891  #+debug
    19881892  (#_NSLog #@"saving file to %@" :id path)
    1989   (send-super :write-with-backup-to-file path :of-type type :save-operation save-operation))
     1893  (call-next-method path type save-operation))
    19901894
    19911895;;; This should be a preference.
    1992 (define-objc-method ((:<BOOL> keep-backup-file)
    1993                      hemlock-editor-document)
    1994   #$YES)
     1896(objc:defmethod (#/keepBackupFile :<BOOL>) ((self hemlock-editor-document))
     1897  t)
    19951898
    19961899
    19971900(defmethod hemlock-document-buffer (document)
    1998   (let* ((string (send (slot-value document 'textstorage) 'string)))
     1901  (let* ((string (#/string (slot-value document 'textstorage))))
    19991902    (unless (%null-ptr-p string)
    20001903      (let* ((cache (hemlock-buffer-string-cache string)))
     
    20121915    panes))
    20131916
    2014 (define-objc-method ((:id :data-representation-of-type type)
    2015                       hemlock-editor-document)
     1917(objc:defmethod #/dataRepresentationOfType: ((self hemlock-editor-document)
     1918                                             type)
    20161919  (declare (ignorable type))
    20171920  (let* ((buffer (hemlock-document-buffer self)))
    20181921    (when buffer
    20191922      (setf (hi::buffer-modified buffer) nil)))
    2020   (send (send (slot-value self 'textstorage) 'string)
    2021         :data-using-encoding #$NSASCIIStringEncoding
    2022         :allow-lossy-conversion t))
     1923  (#/dataUsingEncoding:allowLossyConversion:
     1924   (#/string (slot-value self 'textstorage)) #$NSASCIIStringEncoding t))
    20231925
    20241926
    20251927;;; Shadow the setFileName: method, so that we can keep the buffer
    20261928;;; name and pathname in synch with the document.
    2027 (define-objc-method ((:void :set-file-name full-path)
    2028                      hemlock-editor-document)
    2029   (send-super :set-file-name full-path)
     1929(objc:defmethod (#/setFileName: :void) ((self hemlock-editor-document)
     1930                                        full-path)
     1931  (call-next-method full-path)
    20301932  (let* ((buffer (hemlock-document-buffer self)))
    20311933    (when buffer
     
    20421944(defloadvar *next-editor-y-pos* nil)
    20431945
    2044 (define-objc-method ((:void make-window-controllers) hemlock-editor-document)
     1946(objc:defmethod (#/makeWindowControllers :void) ((self hemlock-editor-document))
    20451947  #+debug
    20461948  (#_NSLog #@"Make window controllers")
     
    20511953                                    nil
    20521954                                    (textview-background-color self)))
    2053          (controller (make-objc-instance
     1955         (controller (make-instance
    20541956                      'hemlock-editor-window-controller
    20551957                      :with-window window)))
    2056     (send self :add-window-controller controller)
    2057     (send controller 'release)
    2058     (slet ((current-point (ns-make-point (or *next-editor-x-pos*
    2059                                              (float *initial-editor-x-pos*
    2060                                                     +cgfloat-zero+))
    2061                                          (or *next-editor-y-pos*
    2062                                              (float *initial-editor-y-pos*
    2063                                                     +cgfloat-zero+)))))
    2064       (slet ((new-point (send window
    2065                               :cascade-top-left-from-point current-point)))
    2066             (setf *next-editor-x-pos* (pref new-point :<NSP>oint.x)
    2067                   *next-editor-y-pos* (pref new-point :<NSP>oint.y))))))
    2068 
    2069 
    2070 (define-objc-method ((:void close) hemlock-editor-document)
     1958    (#/addWindowController: self controller)
     1959    (#/release controller)
     1960    (ns:with-ns-point  (current-point
     1961                        (or *next-editor-x-pos*
     1962                            *initial-editor-x-pos*)
     1963                        (or *next-editor-y-pos*
     1964                            *initial-editor-y-pos*))
     1965      (let* ((new-point (#/cascadeTopLeftFromPoint: window current-point)))
     1966        (setq *next-editor-x-pos* (ns:ns-point-x new-point)
     1967              *next-editor-y-pos* (ns:ns-point-y new-point))))))
     1968
     1969
     1970(objc:defmethod (#/close :void) ((self hemlock-editor-document))
    20711971  #+debug
    20721972  (#_NSLog #@"Document close: %@" :id self)
     
    20771977       textstorage
    20781978       #'(lambda (tv)
    2079            (let* ((layout (send tv 'layout-manager)))
    2080              (send layout :set-background-layout-enabled nil))))
     1979           (let* ((layout (#/layoutManager tv)))
     1980             (#/setBackgroundLayoutEnabled: layout nil))))
    20811981      (close-hemlock-textstorage textstorage)))
    2082   (send-super 'close))
     1982  (call-next-method))
    20831983
    20841984
    20851985(defun initialize-user-interface ()
    2086   (send (find-class 'preferences-panel) 'shared-panel)
     1986  (#/sharedPanel preferences-panel)
    20871987  (update-cocoa-defaults)
    20881988  (make-editor-style-map))
     
    20941994
    20951995(defmethod hemlock::center-text-pane ((pane text-pane))
    2096   (send (text-pane-text-view pane)
    2097         :center-selection-in-visible-area (%null-ptr)))
     1996  (#/centerSelectionInVisibleArea: (text-pane-text-view pane) +null-ptr+))
    20981997
    20991998
    21001999(defun hi::open-document ()
    2101   (send (send (find-class 'ns:ns-document-controller)
    2102               'shared-document-controller)
    2103         :perform-selector-on-main-thread (@selector "openDocument:")
    2104         :with-object (%null-ptr)
    2105         :wait-until-done t))
     2000  (#/performSelectorOnMainThread:withObject:waitUntilDone:
     2001   (#/sharedDocumentController ns:ns-document-controller)
     2002   (@selector #/openDocument:) +null-ptr+ t))
    21062003 
    21072004(defmethod hi::save-hemlock-document ((self hemlock-editor-document))
    2108   (send self
    2109         :perform-selector-on-main-thread (@selector "saveDocument:")
    2110         :with-object (%null-ptr)
    2111         :wait-until-done t))
     2005  (#/performSelectorOnMainThread:withObject:waitUntilDone:
     2006   self (@selector #/saveDocument:) +null-ptr+ t))
    21122007
    21132008
    21142009(defmethod hi::save-hemlock-document-as ((self hemlock-editor-document))
    2115   (send self
    2116         :perform-selector-on-main-thread (@selector "saveDocumentAs:")
    2117         :with-object (%null-ptr)
    2118         :wait-until-done t))
     2010  (#/performSelectorOnMainThread:withObject:waitUntilDone:
     2011   self (@selector #/saveDocumentAs:) +null-ptr+ t))
    21192012
    21202013;;; This needs to run on the main thread.
    2121 (define-objc-method ((:void update-hemlock-selection)
    2122                      hemlock-text-storage)
    2123   (let* ((string (send self 'string))
     2014(objc:defmethod (#/updateHemlockSelection :void) ((self hemlock-text-storage))
     2015  (let* ((string (#/string self))
    21242016         (buffer (buffer-cache-buffer (hemlock-buffer-string-cache string)))
    21252017         (hi::*buffer-gap-context* (hi::buffer-gap-context buffer))
     
    21422034     self
    21432035     #'(lambda (tv)
    2144          (send tv
    2145                :update-selection location
    2146                :length len
    2147                :affinity (if (eql location 0)
    2148                            #$NSSelectionAffinityUpstream
    2149                            #$NSSelectionAffinityDownstream))))))
     2036         (#/updateSelection:length:affinity: tv location len (if (eql location 0) #$NSSelectionAffinityUpstream #$NSSelectionAffinityDownstream))))))
    21502037
    21512038
  • trunk/ccl/examples/cocoa-inspector.lisp

    r430 r6234  
    5757(require "COCOA")
    5858
    59 ; This is useful when @ won't work, dynamically creating a NSString pointer from a string
     59;;; This is useful when @ won't work, dynamically creating a NSString
     60;;; pointer from a string.
     61
    6062(defun nsstringptr (string)
    6163  (objc-constant-string-nsstringptr
    6264   (ns-constant-string string)))
    6365
    64 
     66#+old
    6567(defmacro handler-case-for-cocoa (id form)
    6668  (declare (ignorable id))
     
    231233(defclass inspector-table-view-data-source (ns:ns-object)
    232234    ((inspector-browser :foreign-type :id :reader inspector-browser)
    233      (inspector-window :foreign-type :id :reader inspector-browser))
     235     (inspector-window :foreign-type :id :reader inspector-window))
    234236  (:metaclass ns:+ns-object))
    235237
     
    239241
    240242
    241 ;; is there some reason this is called before the cell is actually selected? In any case,
    242 ;; when a non-leaf cell is selected, this function is called first for the new column,
    243 ;; so it has to push the new element into the cinspector -- what the browserAction will
    244 ;; be left doing it remains to be seen. The only other time this is called AFAICT is
    245 ;; when loadColumnZero or reloadColumn is called
    246 (define-objc-method ((:int :browser browser
    247                            :number-of-rows-in-column (:int column))
    248                            inspector-browser-delegate)
    249   (or (handler-case-for-cocoa 1
    250        (let* ((cinspector (gethash (inspector-window self) *cocoa-inspector-nswindows-table*))
    251               (selected-column (send browser 'selected-column)) ; probably always (1- column), when a column is selected
    252               (cinspector-column (1- selected-column)) ; 2nd column of nsbrowser <-> 1st column of cinspector
    253               (row (send browser :selected-row-in-column selected-column)))
    254          #+ignore
    255          (format t "getting length of column ~d based on row ~d in column ~d~%" column row selected-column)
    256          (cond ((not cinspector) 0)
    257                ((= column 0) 1) ; just displaying the printed representaiton of the top inspected object
    258                ((= selected-column 0) ; selected the printed rep of the inspected object (column should = 1)
    259                 (setf (max-column cinspector) 0) ; crop object-vector in cinspector
    260                 (let ((inspector (nth-inspector cinspector 0))) ; inspector for top object
    261                   (inspector::inspector-line-count inspector)))
    262                ((>= selected-column 1) ; (-1 is the N/A column)
    263                 (setf (max-column cinspector) cinspector-column) ; crop object-vector in cinspector
    264                 (push-object (nth-object-nth-value cinspector cinspector-column row) cinspector)
    265                 (let ((inspector (nth-inspector cinspector (1+ cinspector-column)))) ; inspector for object just pushed
    266                   (inspector::inspector-line-count inspector))))))
     243;;; is there some reason this is called before the cell is actually
     244;;; selected? In any case, when a non-leaf cell is selected, this
     245;;; function is called first for the new column, so it has to push the
     246;;; new element into the cinspector -- what the browserAction will be
     247;;; left doing it remains to be seen. The only other time this is
     248;;; called AFAICT is when loadColumnZero or reloadColumn is called
     249(objc:defmethod (#/browser:numberOfRowsInColumn: :<NSI>nteger)
     250    ((self inspector-browser-delegate)
     251     browser
     252     (column :<NSI>nteger))
     253  (or (let* ((cinspector (gethash (inspector-window self) *cocoa-inspector-nswindows-table*))
     254             (selected-column (#/selectedColumn browser)) ; probably always (1- column), when a column is selected
     255             (cinspector-column (1- selected-column)) ; 2nd column of nsbrowser <-> 1st column of cinspector
     256             (row (#/selectedRowInColumn: browser selected-column)))
     257        #+ignore
     258        (format t "getting length of column ~d based on row ~d in column ~d~%" column row selected-column)
     259        (cond ((not cinspector) 0)
     260              ((= column 0) 1)          ; just displaying the printed representaiton of the top inspected object
     261              ((= selected-column 0)    ; selected the printed rep of the inspected object (column should = 1)
     262               (setf (max-column cinspector) 0) ; crop object-vector in cinspector
     263               (let ((inspector (nth-inspector cinspector 0))) ; inspector for top object
     264                 (inspector::inspector-line-count inspector)))
     265              ((>= selected-column 1)   ; (-1 is the N/A column)
     266               (setf (max-column cinspector) cinspector-column) ; crop object-vector in cinspector
     267               (push-object (nth-object-nth-value cinspector cinspector-column row) cinspector)
     268               (let ((inspector (nth-inspector cinspector (1+ cinspector-column)))) ; inspector for object just pushed
     269                 (inspector::inspector-line-count inspector)))))
    267270      0))
    268271
     
    282285;; In the following method defn this is unnecessary, the Browser can tell this for itself
    283286;; [cell "setLoaded:" :<BOOL> #$YES]
    284 (define-objc-method ((:void :browser browser
    285                             :will-display-cell cell
    286                             :at-row (:int row)
    287                             :column (:int column))
    288                      inspector-browser-delegate)
     287(objc:defmethod (#/browser:willDisplayCell:atRow:column: :void)
     288    ((self inspector-browser-delegate)
     289     browser
     290     cell
     291     (row :<NSI>nteger)
     292     (column :<NSI>nteger))
    289293  (declare (ignorable browser column))
    290   (handler-case-for-cocoa 2
    291    (let ((cinspector (gethash (inspector-window self) *cocoa-inspector-nswindows-table*))
     294     (let ((cinspector (gethash (inspector-window self) *cocoa-inspector-nswindows-table*))
    292295         (cinspector-column (1- column))) ; 2nd column of nsbrowser <-> 1st column of cinspector
    293296     #+ignore
     
    295298     (cond ((not cinspector) nil)
    296299           ((= column 0)
    297             (send cell :set-string-value  (nsstringptr (format nil "~s" (nth-object cinspector 0))))
    298             (send cell :set-leaf nil))
     300            (#/setStringValue: cell  (nsstringptr (format nil "~s" (nth-object cinspector 0))))
     301            (#/setLeaf: cell nil))
    299302           (t
    300             ;; when switching between widgets to the browser, we can have reloaded a column
    301             ;; and need to drill down a row from where we are at the moment
    302             (send cell :set-string-value  (nsstringptr (nth-object-nth-line cinspector cinspector-column row)))
    303             ;; leaf-p should really consider the type of the object in question
    304             ;; (eventually taking into account whether we're brousing the class heirarchy or into objc or whatever)
    305             (send cell :set-leaf (or (leaf-node-p (nth-object cinspector cinspector-column)) ; i.e. no fields drill down
     303            ;; when switching between widgets to the browser, we can
     304            ;; have reloaded a column and need to drill down a row
     305            ;; from where we are at the moment
     306            (#/setStringValue: cell  (nsstringptr (nth-object-nth-line cinspector cinspector-column row)))
     307            ;; leaf-p should really consider the type of the object in
     308            ;; question (eventually taking into account whether we're
     309            ;; browsing the class heirarchy or into objc or whatever)
     310            (#/setLeaf: cell (or (leaf-node-p (nth-object cinspector cinspector-column)) ; i.e. no fields drill down
    306311                                                    (leaf-field-p (nth-object cinspector cinspector-column) row)
    307312                                                    ;; for now...
    308313                                                    (= row 0)
    309                                                     (not (nth-object-nth-value-editable cinspector cinspector-column row)))))))))
    310 
    311 ;; when all is said and done and once the cinspector is properly
    312 ;; populated, the selected object in the browser's nth column is
    313 ;; actually the object in the cinspector's nth column (i.e. because
    314 ;; the selected object is displayed in the next browser column over,
    315 ;; and the cinspector and nsbrowser have a 1-off discrepancy, they
    316 ;; cancel out) -- just a note to make the difference between these
    317 ;; next two functions and the previous two functions
    318 
    319 ;; change the focus of the the table view to be the selected object
    320 (define-objc-method ((:void :browser-action sender)
    321                      inspector-browser-delegate) ; don't know why I'd want to, but could use a separate IBTarget class
     314                                                    (not (nth-object-nth-value-editable cinspector cinspector-column row))))))))
     315
     316;;; when all is said and done and once the cinspector is properly
     317;;; populated, the selected object in the browser's nth column is
     318;;; actually the object in the cinspector's nth column (i.e. because
     319;;; the selected object is displayed in the next browser column over,
     320;;; and the cinspector and nsbrowser have a 1-off discrepancy, they
     321;;; cancel out) -- just a note to make the difference between these
     322;;; next two functions and the previous two functions
     323
     324;;; change the focus of the the table view to be the selected object
     325(objc:defmethod (#/browserAction: :void)
     326    ((self inspector-browser-delegate)
     327     sender); don't know why I'd want to, but could use a separate IBTarget class
    322328  #+ignore (format t "browserAction~%")
    323     (handler-case-for-cocoa 5
    324       (let* ((cinspector (gethash (inspector-window self) *cocoa-inspector-nswindows-table*))
    325              (column (send sender 'selected-column)))
    326         (when (<= 0 column)
    327           (setf (focal-point cinspector) column)
    328           (send (inspector-table-view self) 'reload-data)
    329           #+ignore
    330           (format t "      responding to selection in column ~d~%" column)))))
     329  (let* ((cinspector (gethash (inspector-window self) *cocoa-inspector-nswindows-table*))
     330         (column (#/selectedColumn sender)))
     331    (when (<= 0 column)
     332      (setf (focal-point cinspector) column)
     333      (#/reloadData (inspector-table-view self))
     334      #+ignore
     335      (format t "      responding to selection in column ~d~%" column))))
    331336
    332337;; open a new inspector on the selected object
    333 (define-objc-method ((:void :browser-double-action sender)
    334                      inspector-browser-delegate)
     338(objc:defmethod (#/browserDoubleAction: :void)
     339    ((self inspector-browser-delegate)
     340     sender)
    335341  #+ignore (format t "browserDoubleAction~%")
    336   (handler-case-for-cocoa 6
    337     (let* ((cinspector (gethash (inspector-window self) *cocoa-inspector-nswindows-table*))
    338            (column (send sender 'selected-column)))
    339       (when (<= 0 column)
    340         ; this seems to work, but I'm not really paying attention to thread stuff...
    341         (cinspect (nth-object cinspector column))))))
    342 
    343 (define-objc-method ((:int :number-of-rows-in-table-view table-view)
    344                      inspector-table-view-data-source)
     342  (let* ((cinspector (gethash (inspector-window self) *cocoa-inspector-nswindows-table*))
     343         (column (#/selectedColumn sender)))
     344    (when (<= 0 column)
     345      ;; this seems to work, but I'm not really paying attention to
     346      ;; thread stuff...
     347      (cinspect (nth-object cinspector column)))))
     348
     349(objc:defmethod (#/numberOfRowsInTableView: :<NSI>nteger)
     350    ((self inspector-table-view-data-source)
     351     table-view)
    345352  (declare (ignore table-view))
    346   (or (handler-case-for-cocoa 3
    347       (let ((cinspector (gethash (inspector-window self) *cocoa-inspector-nswindows-table*)))
    348         (if cinspector
    349              (let ((inspector (inspector cinspector)))
    350                (inspector::inspector-line-count inspector))
    351            0)))
     353 
     354  (or (let ((cinspector (gethash (inspector-window self) *cocoa-inspector-nswindows-table*)))
     355        (if cinspector
     356          (let ((inspector (inspector cinspector)))
     357            (inspector::inspector-line-count inspector))
     358          0))
    352359      0))
    353360
    354 
    355 
    356 
    357 (define-objc-method ((:id :table-view table-view
    358                           :object-value-for-table-column table-column
    359                           :row (:int row))
    360                      inspector-table-view-data-source)
     361(objc:defmethod #/tableView:objectValueForTableColumn:row:
     362    ((self inspector-table-view-data-source)
     363     table-view
     364     table-column
     365     (row :<NSI>nteger))
    361366  (declare (ignore table-view))
    362367  (let ((cinspector (gethash (inspector-window self) *cocoa-inspector-nswindows-table*)))
    363368    (cond ((not cinspector)
    364369           #@"")
    365           ((send (send table-column 'identifier) :is-equal #@"property")
     370          ((#/isEqual: (#/identifier table-column) #@"property")
    366371           (nsstringptr (focus-nth-property cinspector row)))
    367           ((send (send table-column 'identifier) :is-equal #@"value")
     372          ((#/isEqual: (#/identifier table-column) #@"value")
    368373           (nsstringptr (focus-nth-value cinspector row))))))
    369374
    370375;; I'm hoping that the delegate will prevent this from being called willy-nilly
    371 (define-objc-method ((:void :table-view table-view
    372                             :set-object-value object
    373                             :for-table-column table-column
    374                             :row (:int row))
    375                      inspector-table-view-data-source)
     376(objc:defmethod (#/tableView:setObjectValue:forTableColumn:row: :void)
     377    ((self inspector-table-view-data-source)
     378     table-view object table-column (row :<NSI>nteger))
    376379  (declare (ignore table-column))
    377   (handler-case-for-cocoa 4
    378380   (let ((cinspector (gethash (inspector-window self) *cocoa-inspector-nswindows-table*)))
    379381     ;; without any formatters, object appears to be an NSCFString
     
    384386       (setf (focus-nth-value cinspector row)
    385387             (let ((*package* (find-package :cl-user)))
    386                ;; with-autorelease-pool could possibly be needed to autorelease the cString we're handling (I think)
    387                (eval (read-from-string (%get-cstring (send object 'c-string))))))
    388        (send table-view 'reload-data) ; really could just reload that one cell, but don't know how...
    389        ;; changing the focused object may effect the browser's path, reload its column and keep the cinspector consistent
    390        ;; Here we have to make sure that the column we're reloading and the column after both have values to display,
    391        ;; for when reloadColumn: invokes browser:willDisplayCell:atRow:column:
    392        (send (inspector-browser self) :reload-column (focal-point cinspector))
     388               ;; with-autorelease-pool could possibly be needed to
     389               ;; autorelease the cString we're handling (I think)
     390               (eval (read-from-string (lisp-string-from-nsstring object)))))
     391       (#/reloadData table-view) ; really could just reload that one cell, but don't know how...
     392       ;; changing the focused object may effect the browser's path,
     393       ;; reload its column and keep the cinspector consistent Here we
     394       ;; have to make sure that the column we're reloading and the
     395       ;; column after both have values to display, for when
     396       ;; reloadColumn: invokes browser:willDisplayCell:atRow:column:
     397       (#/reloadColumn: (inspector-browser self) (focal-point cinspector))
    393398       ;; [inspector-browser "scrollColumnToVisible:" :int (focal-point cinspector)] ; maybe need this, too
    394        ))))
    395 
    396 ; In the table view, the properties are not editable, but the
    397 ; values (if editable) allow lisp forms to be entered that are
    398 ; read and evaluated to determine the new property value.
    399 (define-objc-method ((:<BOOL> :table-view table-view
    400                               :should-edit-table-column table-column
    401                               :row (:int row))
    402                      inspector-table-view-delegate)
     399       )))
     400
     401;;; In the table view, the properties are not editable, but the
     402;;; values (if editable) allow lisp forms to be entered that are
     403;;; read and evaluated to determine the new property value.
     404(objc:defmethod (#/tableView:shouldEditTableColumn:row: :<BOOL>)
     405    ((self inspector-table-view-delegate)
     406     table-view table-column (row :<NSI>nteger))
    403407  (declare (ignore table-view))
    404408  (let ((cinspector (gethash (inspector-window self) *cocoa-inspector-nswindows-table*)))
    405409    (and cinspector
    406           (send (send table-column 'identifier) :is-equal #@"value")
    407           (/= row 0) ; in practice the reference to the object isn't editable, and the GUI semantics aren't clear anyway,
    408                      ; possibly there will come a time when I put row 0 in the table title, but I need to maintain
    409                      ; the 0-indexed focus-nth-whatever API here and elsewhere if I do that
    410           (focus-nth-value-editable cinspector row))))
     410         (#/isEqual: (#/identifier table-column) #@"value")
     411         (/= row 0)                     ; in practice the reference to
     412                                        ; the object isn't editable, and
     413                                        ; the GUI semantics aren't clear anyway,
     414                                        ; possibly there will come a
     415                                        ; time when I put row 0 in the
     416                                        ; table title, but I need to
     417                                        ; maintain the 0-indexed
     418                                        ; focus-nth-whatever API here
     419                                        ; and elsewhere if I do that
     420         (focus-nth-value-editable cinspector row))))
    411421
    412422;; the inspectorwindowcontroller is set up as the delegate of the window...
    413423;; we now eliminate the dangling pointer to the window from the hash table
    414 (define-objc-method ((:void :window-will-close notification)
    415                      inspector-window-controller)
    416   (let ((nswindow (send notification 'object)))
     424(objc:defmethod (#/windowWillClose: :void)
     425    ((self inspector-window-controller) notification)
     426  (let ((nswindow (#/object notification)))
    417427    (remhash nswindow *cocoa-inspector-nswindows-table*)))
    418428
    419 ; hopefully a generally useful function
     429;;; hopefully a generally useful function
    420430(defun load-windowcontroller-from-nib (wc-classname nib-pathname)
    421431  "Takes a NIB name and returns a new window controller"
    422432  (with-autorelease-pool
    423       (make-objc-instance
     433      (make-instance
    424434       wc-classname
    425435       :with-window-nib-name (nsstringptr (namestring nib-pathname)))))
    426436
    427 ; make a new inspector window from the nib file, and hash the window's
    428 ; browser and tableview to the object
     437;;; make a new inspector window from the nib file, and hash the window's
     438;;; browser and tableview to the object
    429439(defun cinspect (object)
    430440  (with-autorelease-pool
    431441      (let* ((windowcontroller (load-windowcontroller-from-nib 'inspector-window-controller *default-inspector-nib-pathname*))
    432              (window (send windowcontroller 'window))
     442             (window (#/window windowcontroller))
    433443             (cinspector (make-instance 'cocoa-inspector)))
    434444        ;; set up the window's initial "focused" object -- this may change as
     
    439449        (setf (gethash window *cocoa-inspector-nswindows-table*) cinspector)
    440450        (push-object object cinspector)
    441         ;; is this working? it isn't breaking, but double-clicking is being handled as two single actions
     451        ;; is this working? it isn't breaking, but double-clicking is
     452        ;; being handled as two single actions
    442453        (let* ((browser (inspector-browser windowcontroller)))
    443           (send browser
    444                 :set-double-action (@SELECTOR "browserDoubleAction:"))
    445           (send browser :set-ignores-multi-click t))
    446         (send windowcontroller :show-window window)
     454          (#/setDoubleAction: browser (@selector #/browserDoubleAction:))
     455          (#/setIgnoresMultiClick: browser t))
     456        (#/showWindow: windowcontroller window)
    447457        window)))
    448458
  • trunk/ccl/examples/cocoa-listener.lisp

    r5731 r6234  
    2727  ;; Since the same (Unix) process will be reading from and writing
    2828  ;; to the pty, it's critical that we make the pty non-blocking.
     29  ;; Has this been true for the last few years (native threads) ?
    2930  (fd-set-flag pty #$O_NONBLOCK)
    3031  (disable-tty-local-modes pty (logior #$ECHO #$ECHOCTL #$ISIG))
     
    6364                 (when doc
    6465                   (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))))
     66                   (#/performSelectorOnMainThread:withObject:waitUntilDone:
     67                    doc
     68                    (@selector #/close)
     69                    +null-ptr+
     70                    nil))))
    6971           :initial-function
    7072           #'(lambda ()
     
    8890;;; Listener documents are never (or always) ediited.  Don't cause their
    8991;;; close boxes to be highlighted.
    90 (define-objc-method ((:void :set-document-edited (:<BOOL> edited))
    91                      hemlock-listener-window-controller)
     92(objc:defmethod (#/setDocumentEdited: :void)
     93    ((self hemlock-listener-window-controller) (edited :<BOOL>))
    9294  (declare (ignorable edited)))
    9395 
    9496
    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)
     97(objc:defmethod #/initWithWindow: ((self hemlock-listener-window-controller) w)
     98  (let* ((new (call-next-method w)))
     99    (unless (%null-ptr-p new)
    99100      (multiple-value-bind (server client) (ignore-errors (open-pty-pair))
    100101        (when server
    101           (let* ((fh (make-objc-instance
    102                       'ns-file-handle
     102          (let* ((fh (make-instance
     103                      'ns:ns-file-handle
    103104                      :with-file-descriptor (setup-server-pty server)
    104105                      :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)
     106            (setf (slot-value new 'filehandle) fh)
     107            (setf (slot-value new 'clientfd) (setup-client-pty client))
     108            (#/addObserver:selector:name:object:
     109             (#/defaultCenter ns:ns-notification-center)
     110             new
     111             (@selector #/gotData:)
     112             #&NSFileHandleReadCompletionNotification
     113             fh)
     114            (#/readInBackgroundAndNotify fh)))))
     115    new))
     116
     117(objc:defmethod (#/gotData: :void) ((self hemlock-listener-window-controller)
     118                                    notification)
     119  #+debug (#_NSLog #@"gotData: !")
    117120  (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))
     121    (let* ((data (#/objectForKey: (#/userInfo notification)
     122                                  #&NSFileHandleNotificationDataItem))
     123           (document (#/document self))
     124           (data-length (#/length data))
    122125           (buffer (hemlock-document-buffer document))
    123            (string (%str-from-ptr (send data 'bytes) data-length))
     126           (string (%str-from-ptr (#/bytes data) data-length))
    124127           (fh filehandle))
    125128      (enqueue-buffer-operation
     
    127130       #'(lambda ()
    128131           (hemlock::append-buffer-output buffer string)))
    129       (send fh 'read-in-background-and-notify))))
     132      (#/readInBackgroundAndNotify fh))))
    130133             
    131134
    132135
    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))
     136(objc:defmethod (#/dealloc :void) ((self hemlock-listener-window-controller))
     137  (#/removeObserver: (#/defaultCenter ns:ns-notification-center) self)
     138  (call-next-method))
    137139
    138140
     
    146148
    147149(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+)))
     150  (#/colorWithCalibratedRed:green:blue:alpha:
     151   ns:ns-color
     152   (float *listener-background-red-component* +cgfloat-zero+)
     153   (float *listener-background-green-component* +cgfloat-zero+)
     154   (float *listener-background-blue-component* +cgfloat-zero+)
     155   (float *listener-background-alpha-component* +cgfloat-zero+)))
    153156
    154157
    155158(defun hemlock::listener-document-send-string (document string)
    156   (let* ((controller (send (send document 'window-controllers)
    157                           :object-at-index 0))
     159  (let* ((controller (#/objectAtIndex: (#/windowControllers document) 0))
    158160         (filehandle (slot-value controller 'filehandle))
    159161         (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))
     162         (data (#/autorelease (make-instance 'ns:ns-mutable-data
     163                                             :with-length len)))
     164         (bytes (#/mutableBytes data)))
    164165    (%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)
     166    (#/writeData: filehandle data)
     167    (#/synchronizeFile filehandle)))
     168
     169
     170(objc:defmethod #/topListener ((self +hemlock-listener-document))
     171  (let* ((all-documents (#/orderedDocuments *NSApp*)))
     172    (dotimes (i (#/count all-documents) (%null-ptr))
     173      (let* ((doc (#/objectAtIndex: all-documents i)))
     174        (when (eql (#/class doc) self)
    174175          (return doc))))))
    175176
    176177(defun symbol-value-in-top-listener-process (symbol)
    177   (let* ((listenerdoc (send (@class hemlock-listener-document) 'top-listener))
     178  (let* ((listenerdoc (#/topListener hemlock-listener-document))
    178179         (buffer (unless (%null-ptr-p listenerdoc)
    179180                   (hemlock-document-buffer listenerdoc)))
     
    185186
    186187
    187 (define-objc-method ((:<BOOL> is-document-edited) hemlock-listener-document)
     188(objc:defmethod (#/isDocumentEdited :<BOOL>) ((self hemlock-listener-document))
    188189  nil)
    189190
    190 
    191 (define-objc-method ((:id init)
    192                      hemlock-listener-document)
    193   (let* ((doc (send-super 'init)))
     191(objc:defmethod #/init ((self hemlock-listener-document))
     192  (let* ((doc (call-next-method)))
    194193    (unless (%null-ptr-p doc)
    195194      (let* ((listener-name (if (eql 1 (incf *cocoa-listener-count*))
     
    199198             (buffer (hemlock-document-buffer doc)))
    200199        (setf (slot-value (slot-value self 'textstorage) 'append-edits) 1)
    201         (send doc :set-file-name  (%make-nsstring listener-name))
     200        (#/setFileName: doc  (%make-nsstring listener-name))
    202201        (setf (hi::buffer-pathname buffer) nil
    203202              (hi::buffer-minor-mode buffer "Listener") t
     
    213212(defloadvar *next-listener-y-pos* nil) ; likewise
    214213
    215 (define-objc-method ((:void make-window-controllers) hemlock-listener-document)
     214(objc:defmethod (#/makeWindowControllers :void) ((self hemlock-listener-document))
    216215  (let* ((textstorage (slot-value self 'textstorage))
    217216         (window (%hemlock-frame-for-textstorage
    218                                     textstorage
    219                                     *listener-columns*
    220                                     *listener-rows*
    221                                     t
    222                                     (textview-background-color self)))
    223          (controller (make-objc-instance
     217                  textstorage
     218                  *listener-columns*
     219                  *listener-rows*
     220                  t
     221                  (textview-background-color self)))
     222         (controller (make-instance
    224223                      'hemlock-listener-window-controller
    225224                      :with-window window))
    226225         (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))))
     226    ;; Disabling background layout on listeners is an attempt to work
     227    ;; around a bug.  The bug's probably gone ...
     228    (let* ((layout-managers (#/layoutManagers textstorage)))
     229      (dotimes (i (#/count layout-managers))
     230        (let* ((layout (#/objectAtIndex: layout-managers i)))
     231          (#/setBackgroundLayoutEnabled: layout nil))))
     232    (#/addWindowController: self controller)
     233    (#/release controller)
     234    (ns:with-ns-point (current-point
     235                       (or *next-listener-x-pos* *initial-listener-x-pos*)
     236                       (or *next-listener-y-pos* *initial-listener-y-pos*))
     237      (let* ((new-point (#/cascadeTopLeftFromPoint: window current-point)))
     238        (setf *next-listener-x-pos* (ns:ns-point-x new-point)
     239              *next-listener-y-pos* (ns:ns-point-y new-point))))
    243240    (setf (hi::buffer-process (hemlock-document-buffer self))
    244241          (let* ((tty (slot-value controller 'clientfd))
    245                  (peer-tty (send (slot-value controller 'filehandle)
    246                                  'file-descriptor)))
     242                 (peer-tty (#/fileDescriptor (slot-value controller 'filehandle))))
    247243            (new-cocoa-listener-process listener-name tty tty peer-tty)))
    248244    controller))
    249245
    250246;;; Action methods
    251 (define-objc-method ((:void :interrupt sender) hemlock-listener-document)
     247(objc:defmethod (#/interrupt: :void) ((self hemlock-listener-document) sender)
    252248  (declare (ignore sender))
    253249  (let* ((buffer (hemlock-document-buffer self))
     
    259255  (car (cocoa-listener-process-backtrace-contexts proc)))
    260256
    261 (define-objc-method ((:void :backtrace sender) hemlock-listener-document)
     257(objc:defmethod (#/backtrace: :void) ((self hemlock-listener-document) sender)
    262258  (declare (ignore sender))
    263259  (let* ((buffer (hemlock-document-buffer self))
     
    266262      (let* ((context (listener-backtrace-context process)))
    267263        (when context
    268           (send (backtrace-controller-for-context context)
    269                 :show-window (%null-ptr)))))))
     264          (#/showWindow: (backtrace-controller-for-context context) +null-ptr+))))))
    270265
    271266;;; Menu item action validation.  It'd be nice if we could distribute this a
     
    280275         (process (if buffer (hi::buffer-process buffer))))
    281276    (if (typep process 'cocoa-listener-process)
    282       (let* ((action (send item 'action)))
     277      (let* ((action (#/action item)))
    283278        (cond
    284           ((eql action (@selector "interrupt:")) (values t t))
    285           ((eql action (@selector "backtrace:"))
     279          ((eql action (@selector #/interrupt:)) (values t t))
     280          ((eql action (@selector #/backtrace:))
    286281           (values t
    287282                   (not (null (listener-backtrace-context process)))))))
    288283      (values nil nil))))
    289284
    290 (define-objc-method ((:<BOOL> :validate-menu-item item)
    291                      hemlock-listener-document)
     285(objc:defmethod (#/validateMenuItem: :<BOOL>)
     286    ((self hemlock-listener-document) item)
    292287  (multiple-value-bind (have-opinion opinion)
    293288      (document-validate-menu-item self item)
    294289    (if have-opinion
    295290      opinion
    296       (send-super :validate-menu-item item))))
     291      (call-next-method item))))
    297292
    298293(defun shortest-package-name (package)
     
    329324                                                    selection)
    330325  (declare (ignore selection))
    331   (let* ((top-listener-document (send (find-class 'hemlock-listener-document)
    332                                       'top-listener)))
     326  (let* ((top-listener-document (#/topListener hemlock-listener-document)))
    333327    (if top-listener-document
    334328      (let* ((buffer (hemlock-document-buffer top-listener-document)))
  • trunk/ccl/examples/cocoa-prefs.lisp

    r5885 r6234  
    3838  (let* ((doc (cocoa-default-doc default))
    3939         (type (cocoa-default-type default)))
    40     (send cell :set-tag index)
    41           (send cell :set-string-value val)
    42           (when doc
    43             (send form
    44                   :set-tool-tip (%make-nsstring doc)
    45                   :for-cell cell))
    46           (case type
    47             (:int
    48              (send cell :set-entry-type #$NSIntType)
    49              '(send cell :set-alignment #$NSRightTextAlignment))
    50             (:float
    51              (send cell :set-entry-type #$NSFloatType)
    52              '(send cell :set-alignment #$NSRightTextAlignment))
    53             (t
    54              (send cell :set-scrollable t)))
    55           (send cell :set-action (@selector "notePrefsChange:"))
    56           (send cell :set-target self)))
     40    (#/setTag: cell index)
     41    (#/setStringValue: cell val)
     42    (when doc
     43      (#/setToolTip:forCell: form (%make-nsstring doc) cell))
     44    (case type
     45      (:int
     46       (#/setEntryType: cell #$NSIntType)
     47       '(#/setAlignment: cell #$NSRightTextAlignment))
     48      (:float
     49       (#/setEntryType: cell #$NSFloatType)
     50       '(#/setAlignment: cell #$NSRightTextAlignment))
     51      (t
     52       (#/setScrollable: cell t)))
     53    (#/setAction: cell (@selector #/notePrefsChange:))
     54    (#/setTarget: cell self)))
    5755
    5856(defmethod create-prefs-view-form ((self prefs-view))
    59   (let* ((scrollview (prefs-view-scroll-view self)))
    60     (slet* ((contentsize (send scrollview 'content-size))
    61             (form-frame (ns-make-rect
    62                          +cgfloat-zero+
    63                          +cgfloat-zero+
    64                          (pref contentsize :<NSS>ize.width)
    65                          (pref contentsize :<NSS>ize.height))))
    66       (let* ((form (make-objc-instance 'ns:ns-form :with-frame form-frame)))
    67         (send form :set-scrollable t)
    68         (send form :set-intercell-spacing (ns-make-size (float 1.0f0 +cgfloat-zero+) (float 4.0f0 +cgfloat-zero+)))
    69         (send form :set-cell-size (ns-make-size (float 500.0f0 +cgfloat-zero+) (float 22.0f0 +cgfloat-zero+)))
    70         (setf (prefs-view-form self) form)
    71         (send scrollview :set-document-view form)
    72         form))))
     57  (let* ((scrollview (prefs-view-scroll-view self))
     58         (contentsize (#/contentSize scrollview)))
     59    (ns:with-ns-rect (form-frame 0 0 (ns:ns-size-width contentsize) (ns:ns-size-height contentsize))
     60      (ns:with-ns-size (intercell-spacing-size 1 4)
     61        (ns:with-ns-size (cell-size 500 22)
     62          (let* ((form (make-instance 'ns:ns-form :with-frame form-frame)))
     63            (#/setScrollable: form t)
     64            (#/setIntercellSpacing: form intercell-spacing-size)
     65            (#/setCellSize: form cell-size)
     66            (setf (prefs-view-form self) form)
     67            (#/setDocumentView: scrollview form)
     68            form))))))
    7369
    7470(defmethod init-prefs-form-from-defaults ((self prefs-view))
     
    7672                         (apply #'vector (reverse (cocoa-defaults)))))
    7773         (form (create-prefs-view-form self))
    78          (domain (setf (prefs-view-domain self) (send (@class "NSUserDefaults") 'standard-user-defaults)))
     74         (domain (setf (prefs-view-domain self) (#/standardUserDefaults ns:ns-user-defaults)))
    7975         (n (length defaults)))
    8076    (setf (prefs-view-nvalues self) n)
     
    8278      (let* ((d (svref defaults i))
    8379             (key (objc-constant-string-nsstringptr (cocoa-default-string d)))
    84              (val (send domain :object-for-key key)))
     80             (val (#/objectForKey: domain key)))
    8581        (when (%null-ptr-p val)
    86           (send domain
    87                 :set-object (setq val (%make-nsstring (format nil "~a" (cocoa-default-value d))))
    88                 :for-key key))
     82          (#/setObject:forKey:
     83           domain (setq val (%make-nsstring (format nil "~a" (cocoa-default-value d)))) key))
    8984        (set-prefs-cell-from-default self
    90                                      (send form :add-entry key)
     85                                     (#/addEntry: form key)
    9186                                     d
    9287                                     form
     
    9489                                     i)))
    9590    (setf (prefs-view-nchanges self) 0)
    96     (send (prefs-view-revert-button self) :set-enabled nil)
    97     (send (prefs-view-commit-button self) :set-enabled nil)
    98     (send form 'size-to-cells)))
    99 
    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)))
     91    (#/setEnabled: (prefs-view-revert-button self) nil)
     92    (#/setEnabled: (prefs-view-commit-button self) nil)
     93    (#/sizeToCells form)))
     94
     95(objc:defmethod (#/notePrefsChange: :void) ((self prefs-view) form)
     96  (let* ((cell (#/cellAtIndex: form (#/indexOfSelectedItem form)))
    10297         (n (prefs-view-nvalues self))
    10398         (form (prefs-view-form self))
    104          (current (send cell 'tag))
     99         (current (#/tag  cell))
    105100         (d (svref (prefs-view-defaults-vector self) current))
    106101         (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))))
     102         (value (#/stringValue cell)))
     103    (unless (#/isEqualTo: value
     104                          (#/objectForKey: (prefs-view-domain self)
     105                                           (objc-constant-string-nsstringptr (cocoa-default-string d))))
    113106      ;; If there's a constraint, sanity-check the value.
    114107      (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))
     108        (#/setEnabled: (prefs-view-commit-button self) t)
     109        (#/setEnabled:  (prefs-view-revert-button self) t))
    117110      (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)
     111    (#/selectCell: form (#/cellAtIndex: form next))))
     112
     113(objc:defmethod (#/commitPrefs: :void) ((self prefs-view) sender)
    121114  (declare (ignore sender))
    122115  (let* ((form (prefs-view-form self))
    123116         (domain (prefs-view-domain self)))
    124117    (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)
     118      (let* ((cell (#/cellAtIndex: form i))
     119             (key (#/title  cell))
     120             (val (#/stringValue  cell)))
     121        (#/setObject:forKey: domain val key)))
     122    (#/synchronize domain)
    130123    (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)
     124    (#/setEnabled: (prefs-view-revert-button self) nil)
     125    (#/setEnabled: (prefs-view-commit-button self) nil)
    133126    (update-cocoa-defaults-vector domain (prefs-view-defaults-vector self))))
    134127
    135 (define-objc-method ((:void :revert-prefs sender) prefs-view)
     128(objc:defmethod (#/revertPrefs: :void) ((self prefs-view) sender)
    136129  (declare (ignore sender))
    137130  (let* ((form (prefs-view-form self))
    138131         (domain (prefs-view-domain self)))
    139132    (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))))
     133      (let* ((cell (#/cellAtIndex: form i))
     134             (key (#/title cell)))
     135        (#/setStringValue: cell (#/objectForKey: domain key))))
    143136    (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)))
     137    (#/setEnabled: (prefs-view-revert-button self) nil)
     138    (#/setEnabled: (prefs-view-commit-button self) nil)))
    146139
    147140 
    148 (define-objc-method ((:id :init-with-frame (:<NSR>ect frame))
    149                      prefs-view)
    150   (send-super :init-with-frame frame)
    151   (slet ((scroll-frame (ns-make-rect (float 20.0f0 +cgfloat-zero+)
    152                                      (float 40.0f0 +cgfloat-zero+)
    153                                      (- (pref frame :<NSR>ect.size.width) 40.0f0)
    154                                      (- (pref frame :<NSR>ect.size.height) 60.0f0))))
    155     (let* ((scrollview (make-objc-instance 'ns:ns-scroll-view
    156                                            :with-frame scroll-frame))
    157            (scroll-content (send scrollview 'content-view)))
    158       (send scrollview :set-border-type #$NSBezelBorder)
    159       (send scrollview :set-has-vertical-scroller t)
    160       (send scrollview :set-has-horizontal-scroller t)
    161       (send scrollview :set-rulers-visible nil)
    162       (send scrollview :set-autoresizing-mask (logior
    163                                                #$NSViewWidthSizable
    164                                                #$NSViewHeightSizable))
    165       (send scroll-content :set-autoresizes-subviews t)
     141(objc:defmethod #/initWithFrame: ((self prefs-view) (frame :<NSR>ect))
     142  (call-next-method frame)
     143  (ns:with-ns-rect (scroll-frame 20 40 (- (ns:ns-rect-width frame) 40) (- (ns:ns-rect-height frame) 60))
     144    (let* ((scrollview (make-instance 'ns:ns-scroll-view
     145                                      :with-frame scroll-frame))
     146           (scroll-content (#/contentView scrollview)))
     147      (#/setBorderType: scrollview #$NSBezelBorder)
     148      (#/setHasVerticalScroller: scrollview t)
     149      (#/setHasHorizontalScroller: scrollview t)
     150      (#/setRulersVisible: scrollview nil)
     151      (#/setAutoresizingMask: scrollview (logior
     152                                          #$NSViewWidthSizable
     153                                          #$NSViewHeightSizable))
     154      (#/setAutoresizesSubviews: scroll-content t)
    166155      (setf (slot-value self 'scroll-view) scrollview)
    167       (slet ((revert-frame (ns-make-rect (float 20.0f0 +cgfloat-zero+)
    168                                          (float 10.0f0 +cgfloat-zero+)
    169                                          (float 80.0f0 +cgfloat-zero+)
    170                                          (float 20.0f0 +cgfloat-zero+)))
    171              (commit-frame (ns-make-rect (- (+ (pref frame :<NSR>ect.origin.x)
    172                                                (pref frame :<NSR>ect.size.width))
    173                                             (+ 80.0f0 20.0f0))
    174                                          (float 10.0f0 +cgfloat-zero+)
    175                                          (float 80.0f0 +cgfloat-zero+)
    176                                          (float 20.0f0 +cgfloat-zero+))))
    177         (let* ((commit-button (make-objc-instance
     156      (ns:with-ns-rect (revert-frame 20 10 80 20)
     157        (ns:with-ns-rect (commit-frame (- (+ (ns:ns-rect-x frame)
     158                                             (ns:ns-rect-width frame)
     159                                             (+ 80.0f0 20.0f0)))
     160                                       10 80 20)
     161        (let* ((commit-button (make-instance
    178162                               'ns:ns-button
    179163                               :with-frame commit-frame))
    180                (revert-button (make-objc-instance
     164               (revert-button (make-instance
    181165                               'ns:ns-button
    182166                               :with-frame revert-frame)))
    183           (send commit-button :set-title #@"Commit")
    184           (send revert-button :set-title #@"Revert")
    185           (send commit-button :set-enabled nil)
    186           (send revert-button :set-enabled nil)
    187           (send commit-button :set-action (@selector "commitPrefs:"))
    188           (send commit-button :set-target self)
    189           (send revert-button :set-action (@selector "revertPrefs:"))
    190           (send revert-button :set-target self)
    191           (send commit-button :set-autoresizing-mask #$NSViewMinXMargin)
    192           (send revert-button :set-autoresizing-mask #$NSViewMaxXMargin)
    193           (send revert-button :set-bezel-style #$NSRoundedBezelStyle)
    194           (send commit-button :set-bezel-style #$NSRoundedBezelStyle)
     167          (#/setTitle: commit-button #@"Commit")
     168          (#/setTitle: revert-button #@"Revert")
     169          (#/setEnabled: commit-button nil)
     170          (#/setEnabled: revert-button nil)
     171          (#/setAction: commit-button (@selector "commitPrefs:"))
     172          (#/setTarget: commit-button self)
     173          (#/setAction: revert-button (@selector "revertPrefs:"))
     174          (#/setTarget: revert-button self)
     175          (#/setAutoresizingMask: commit-button #$NSViewMinXMargin)
     176          (#/setAutoresizingMask: revert-button #$NSViewMaxXMargin)
     177          (#/setBezelStyle: revert-button #$NSRoundedBezelStyle)
     178          (#/setBezelStyle: commit-button #$NSRoundedBezelStyle)
    195179          (setf (prefs-view-revert-button self) revert-button
    196180                (prefs-view-commit-button self) commit-button)
    197           (send self :add-subview revert-button)
    198           (send self :add-subview commit-button)
    199           (send self :add-subview scrollview)
    200           self)))))
     181          (#/addSubview: self revert-button)
     182          (#/addSubview: self commit-button)
     183          (#/addSubview: self scrollview)
     184          self))))))
    201185
    202186(defloadvar *preferences-panel* nil)
     
    206190  (:metaclass ns:+ns-object))
    207191
    208 (define-objc-class-method ((:id shared-panel) preferences-panel)
     192(objc:defmethod #/sharedPanel ((self +preferences-panel))
    209193  (cond (*preferences-panel*)
    210194        (t
     
    212196                                         :title "Preferences"
    213197                                         :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)
     198                (view (#/contentView panel))
     199                (bounds (#/bounds view))
     200                (v (make-instance 'prefs-view :with-frame bounds)))
     201           (#/setContentView: panel v)
     202           (#/setNeedsDisplay: v t)
     203           (setf (slot-value panel 'prefs-view) v)
     204           (setq *preferences-panel* panel)))))
     205
     206(objc:defmethod #/init ((self preferences-panel))
    223207  (let* ((class (class-of self)))
    224     (send self 'dealloc)
    225     (send class 'shared-panel)))
    226 
    227 (define-objc-method ((:void show) preferences-panel)
     208    (#/dealloc self)
     209    (#/sharedPanel class)))
     210
     211(objc:defmethod (#/show :void) ((self preferences-panel))
    228212  (init-prefs-form-from-defaults (preferences-panel-prefs-view self))
    229   (send self :make-key-and-order-front (%null-ptr)))
     213  (#/makeKeyAndOrderFront: self +null-ptr+))
     214
  • trunk/ccl/examples/cocoa-typeout.lisp

    r5885 r6234  
    3131  (:metaclass ns:+ns-object))
    3232
    33 (define-objc-method ((:id :init-with-frame (:<NSR>ect frame))
    34                      typeout-view)
    35   (send-super :init-with-frame frame)
    36   (let* ((scrollview (make-objc-instance 'ns:ns-scroll-view
    37                                          :with-frame frame))
    38          (scroll-content (send scrollview 'content-view)))
    39     (send scrollview :set-border-type #$NSBezelBorder)
    40     (send scrollview :set-has-vertical-scroller t)
    41     (send scrollview :set-has-horizontal-scroller nil)
    42     (send scrollview :set-rulers-visible nil)
    43     (send scrollview :set-autoresizing-mask #$NSViewHeightSizable)
    44     (send scroll-content :set-autoresizes-subviews t)
    45     (send self :add-subview scrollview)
     33(objc:defmethod #/initWithFrame: ((self typeout-view) (frame :<NSR>ect))
     34  (call-next-method frame)
     35  (let* ((scrollview (make-instance 'ns:ns-scroll-view
     36                                    :with-frame frame))
     37         (scroll-content (#/contentView scrollview)))
     38    (#/setBorderType: scrollview #$NSBezelBorder)
     39    (#/setHasVerticalScroller: scrollview t)
     40    (#/setHasHorizontalScroller: scrollview nil)
     41    (#/setRulersVisible: scrollview nil)
     42    (#/setAutoresizingMask: scrollview #$NSViewHeightSizable)
     43    (#/setAutoresizesSubviews: scroll-content t)
     44    (#/addSubview: self scrollview)
    4645    (setf (slot-value self 'scroll-view) scrollview)
    47     (slet* ((contentsize (send scrollview 'content-size))
    48             (text-frame (ns-make-rect
    49                          +cgfloat-zero+
    50                          +cgfloat-zero+
    51                          (pref contentsize :<NSS>ize.width)
    52                          (pref contentsize :<NSS>ize.height))))
    53            (let* ((text-view (make-objc-instance 'ns:ns-text-view
    54                                             :with-frame text-frame))
    55                   (text-storage (send text-view 'text-storage)))
    56              (send text-view :set-editable 0)
    57              (setf (slot-value self 'text-storage) text-storage)
    58              (send scrollview :set-document-view text-view)
    59              (setf (slot-value self 'text-view) text-view))))
     46    (let* ((contentsize (#/contentSize scrollview)))
     47      (ns:with-ns-rect (text-frame 0 0 (ns:ns-size-width contentsize) (ns:ns-size-height contentsize))
     48        (let* ((text-view (make-instance 'ns:ns-text-view
     49                                         :with-frame text-frame))
     50               (text-storage (#/textStorage text-view)))
     51          (#/setEditable: text-view nil)
     52          (setf (slot-value self 'text-storage) text-storage)
     53          (#/setDocumentView: scrollview text-view)
     54          (setf (slot-value self 'text-view) text-view)))))
    6055  self)
    6156
     
    6964  (:metaclass ns:+ns-object))
    7065
    71 (define-objc-class-method ((:id shared-panel)
    72                            typeout-panel)
     66(objc:defmethod #/sharedPanel ((self +typeout-panel))
    7367  (cond (*typeout-panel*)
    7468        (t
     
    7771                                         :width 600
    7872                                         :activate nil)))
    79            (rlet ((size :<NSS>ize
    80                     :width (float 600.0f0 +cgfloat-zero+)
    81                     :height (float 10000.0f0 +cgfloat-zero+)))
    82                  (send panel :set-max-size size)
    83                  (setf (pref size :<NSS>ize.height) (float 1.0f0 +cgfloat-zero+))
    84                  (send panel :set-min-size size))
    85            (slet ((bounds (send (send panel 'content-view) 'bounds)))
    86                  (let* ((view (make-instance 'typeout-view :with-frame bounds)))
    87                    (send panel :set-content-view view)
    88                    (send view :set-needs-display t)
    89                    (setf (slot-value panel 'typeout-view) view)
    90                    (setq *typeout-panel* panel)))))))
     73           (ns:with-ns-size (size 600 10000)
     74             (#/setMaxSize: panel size)
     75             (setf (ns:ns-size-height size) 1)
     76             (#/setMinSize: panel size))
     77           (let* ((view (make-instance 'typeout-view :with-frame (#/bounds (#/contentView panel)))))
     78             (#/setContentView: panel view)
     79             (#/setNeedsDisplay: view t)
     80             (setf (slot-value panel 'typeout-view) view)
     81             (setq *typeout-panel* panel))))))
    9182
    92 (define-objc-method ((:id init)
    93                      typeout-panel)
     83(objc:defmethod #/init ((self typeout-panel))
    9484  (let* ((class (class-of self)))
    95     (send self 'dealloc)
    96     (send class 'shared-panel)))
     85    (#/dealloc self)
     86    (#/sharedPanel class)))
    9787
    98 (define-objc-method ((:void show)
    99                      typeout-panel)
    100   (send self :order-front (%null-ptr)))
     88
     89(objc:defmethod (#/show :void) ((self typeout-panel))
     90  (#/orderFront: self +null-ptr+))
    10191
    10292(defloadvar *typeout-attributes* nil)
     
    10898
    10999(defun prepare-typeout-stream (stream)
    110   (let ((panel (send (@class typeout-panel) 'shared-panel)))
     100  (let ((panel (#/sharedPanel typeout-panel)))
    111101    (unless (typeout-stream-text-storage stream)
    112102      (setf (typeout-stream-text-storage stream) (typeout-view-text-storage (typeout-panel-typeout-view panel))))
     
    115105                                  :font (default-font :name *default-font-name* :size *default-font-size*)
    116106                                  :line-break-mode :word)))
    117     (send panel 'show)))
     107    (#/show panel)))
    118108
    119109
     
    151141  ;;  it to the text-storage buffer.
    152142  ;;
    153   (let* ((typeout-view (typeout-panel-typeout-view *typeout-panel*))
    154          (text-storage (slot-value typeout-view 'text-storage))
     143  (let* ((the-typeout-view (typeout-panel-typeout-view *typeout-panel*))
     144         (text-storage (slot-value the-typeout-view 'text-storage))
    155145         (str (make-string 1 :initial-element char))
    156146         (attr-str (make-instance 'ns:ns-attributed-string
    157147                                  :with-string str
    158148                                  :attributes *typeout-attributes*)))
    159     (send text-storage :append-attributed-string attr-str)))
     149    (#/appendAttributedString: text-storage attr-str)))
    160150
    161151(defmethod stream-write-string ((stream typeout-stream) string &optional (start 0) end)
     
    167157                                  :with-string str
    168158                                  :attributes *typeout-attributes*))
    169          (typeout-view (typeout-panel-typeout-view *typeout-panel*))
    170          (text-storage (slot-value typeout-view 'text-storage)))
     159         (the-typeout-view (typeout-panel-typeout-view *typeout-panel*))
     160         (text-storage (slot-value the-typeout-view 'text-storage)))
    171161    (setf (typeout-stream-line-position stream) (length string))
    172     (send text-storage :append-attributed-string attr-str)))
     162    (#/appendAttributedString: text-storage attr-str)))
    173163
    174164(defmethod stream-fresh-line ((stream typeout-stream))
     
    181171(defmethod stream-clear-output ((stream typeout-stream))
    182172  (prepare-typeout-stream stream)
    183   (let* ((typeout-view (typeout-panel-typeout-view *typeout-panel*))
    184          (text-storage (slot-value typeout-view 'text-storage))
    185          (len (send text-storage 'length)))
     173  (let* ((the-typeout-view (typeout-panel-typeout-view *typeout-panel*))
     174         (text-storage (slot-value the-typeout-view 'text-storage))
     175         (len (#/length text-storage)))
    186176    (declare (type ns:ns-text-storage text-storage))
    187     (send text-storage :delete-characters-in-range (ns-make-range 0 len))))
     177    (rlet ((range-for-deletion :ns-range :location 0 :length len))
     178      (#/deleteCharactersInRange: text-storage range-for-deletion))))
    188179
    189180(defloadvar *typeout-stream* (make-instance 'typeout-stream))
  • trunk/ccl/examples/cocoa-window.lisp

    r5911 r6234  
    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) progname))
    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 preferences-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)
    258   (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)))
     249  (let* ((p (make-instance 'ns:ns-mutable-paragraph-style))
     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)
    273       (let* ((tabstop (make-objc-instance
    274                        'ns-text-tab
     261      (let* ((tabstop (make-instance
     262                       'ns:ns-text-tab
    275263                       :with-type #$NSLeftTabStopType
    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))
     
    284272                                    (obliqueness nil)
    285273                                    (stroke-width nil))
    286   (let* ((dict (make-objc-instance
    287                 'ns-mutable-dictionary
    288                 :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)
     274  (let* ((dict (#/retain (make-instance 'ns:ns-mutable-dictionary :with-capacity 5))))
     275    (#/setObject:forKey: dict (create-paragraph-style font line-break-mode) #&NSParagraphStyleAttributeName)
     276    (#/setObject:forKey: dict font #&NSFontAttributeName)
    294277    (when color
    295       (send dict :set-object color :for-key #&NSForegroundColorAttributeName))
     278      (#/setObject:forKey: dict color #&NSForegroundColorAttributeName))
    296279    (when stroke-width
    297       (send dict :set-object (make-objc-instance 'ns:ns-number
    298                                                 :with-float (float stroke-width))
    299             :for-key #&NSStrokeWidthAttributeName))
     280      (#/setObject:forKey: dict (make-instance 'ns:ns-number
     281                                               :with-float (float stroke-width)) #&NSStrokeWidthAttributeName))
    300282    (when obliqueness
    301       (send dict :set-object (make-objc-instance 'ns:ns-number
    302                                                 :with-float (float obliqueness))
    303             :for-key #&NSObliquenessAttributeName))
     283      (#/setObject:forKey:  dict (make-instance 'ns:ns-number
     284                                                :with-float (float obliqueness)) #&NSObliquenessAttributeName))
    304285    dict))
    305286
     
    308289  (case flagname
    309290    (:accepts-mouse-moved-events
    310      (send w 'accepts-mouse-moved-events))
     291     (#/acceptsMouseMovedEvents w))
    311292    (:cursor-rects-enabled
    312      (send w 'are-cursor-rects-enabled))
     293     (#/areCursorRectsEnabled w))
    313294    (:auto-display
    314      (send w 'is-autodisplay))))
     295     (#/isAutodisplay w))))
    315296
    316297
     
    319300  (case flagname
    320301    (:accepts-mouse-moved-events
    321      (send w :set-accepts-mouse-moved-events value))
     302     (#/setAcceptsMouseMovedEvents: w value))
    322303    (:auto-display
    323      (send w :set-autodisplay value))))
     304     (#/setAutodisplay: w value))))
    324305
    325306
     
    327308(defun activate-window (w)
    328309  ;; Make w the "key" and frontmost window.  Make it visible, if need be.
    329   (send w :make-key-and-order-front nil))
     310  (#/makeKeyAndOrderFront: w nil))
    330311
    331312(defun new-cocoa-window (&key
     
    345326                         (auto-display t)
    346327                         (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+)))
     328  (ns:with-ns-rect (frame x y width height)
    352329    (let* ((stylemask
    353330            (logior #$NSTitledWindowMask
     
    372349            auto-display)
    373350      (when activate (activate-window w))
    374       (when title (send w :set-title (%make-nsstring title)))
     351      (when title (#/setTitle: w (%make-nsstring title)))
    375352      w)))
    376353
  • trunk/ccl/examples/cocoa.lisp

    r5695 r6234  
    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)
     39(objc:defmethod (#/newListener: :void) ((self lisp-application-delegate)
     40                                        sender)
    4041  (declare (ignore sender))
    41   (send (send (@class ns-document-controller) 'shared-document-controller)
    42         :open-untitled-document-of-type #@"Listener" :display t))
     42  (#/openUntitledDocumentOfType:display:
     43   (#/sharedDocumentController ns:ns-document-controller)
     44   #@"Listener"
     45   t))
    4346
    4447(defvar *cocoa-application-finished-launching* (make-semaphore)
    4548  "Semaphore that's signaled when the application's finished launching ...")
    4649
    47 (define-objc-method ((:void :application-did-finish-launching notification)
    48                      lisp-application-delegate)
     50(objc:defmethod (#/applicationDidFinishLaunching: :void)
     51    ((self lisp-application-delegate) notification)
    4952  (declare (ignore notification))
    5053  (signal-semaphore *cocoa-application-finished-launching*))
    5154
    52 
    53 (define-objc-method ((:<BOOL> :application-open-untitled-file app)
    54                      lisp-application-delegate)
     55(objc:defmethod (#/applicationOpenUntitledFile: :<BOOL>)
     56    ((self lisp-application-delegate) app)
    5557  (when (zerop *cocoa-listener-count*)
    56     (send self :new-listener app)
     58    (#/newListener: self app)
    5759    t))
    5860
     
    8587  (ui-object-exit-backtrace-context o (car args)))
    8688
    87 
    8889(start-cocoa-application)
    8990
     91
Note: See TracChangeset for help on using the changeset viewer.