Changeset 568
- Timestamp:
- Feb 24, 2004, 12:31:29 PM (21 years ago)
- Location:
- trunk/ccl/examples
- Files:
-
- 4 edited
-
cocoa-editor.lisp (modified) (7 diffs)
-
cocoa-listener.lisp (modified) (3 diffs)
-
cocoa-window.lisp (modified) (1 diff)
-
hemlock-textstorage.lisp (modified) (9 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/ccl/examples/cocoa-editor.lisp
r563 r568 23 23 24 24 25 (defparameter *default-font-name* "Courier")26 (defparameter *default-font-size* 12.0e0)27 28 29 ;;; Try to find the specified font. If it doesn't exist (or isn't30 ;;; fixed-pitch), try to find a fixed-pitch font of the indicated size.31 (defun default-font (&key (name *default-font-name*)32 (size *default-font-size*))33 (setq size (float size 0.0f0))34 (with-cstrs ((name name))35 (with-autorelease-pool36 (rletz ((matrix (:array :float 6)))37 (setf (%get-single-float matrix 0) size38 (%get-single-float matrix 12) size)39 (let* ((fontname (send (@class ns-string) :string-with-c-string name))40 (font (send (@class ns-font)41 :font-with-name fontname :matrix matrix)))42 (if (or (%null-ptr-p font)43 (and44 (not (send font 'is-fixed-pitch))45 (not (eql #$YES (objc-message-send font "_isFakeFixedPitch" :<BOOL>)))))46 (setq font (send (@class ns-font)47 :user-fixed-pitch-font-of-size size)))48 font)))))49 25 50 26 (defun size-of-char-in-font (f) … … 96 72 97 73 98 (defparameter *tab-width* 8)99 74 100 ;;; Create a paragraph style, mostly so that we can set tabs reasonably.101 (defun create-paragraph-style (font line-break-mode)102 (let* ((p (make-objc-instance 'ns-mutable-paragraph-style))103 (charwidth (send (send font 'screen-font)104 :width-of-string #@" ")))105 (send p106 :set-line-break-mode107 (ecase line-break-mode108 (:char #$NSLineBreakByCharWrapping)109 (:word #$NSLineBreakByWordWrapping)110 ;; This doesn't seem to work too well.111 ((nil) #$NSLineBreakByClipping)))112 ;; Clear existing tab stops.113 (send p :set-tab-stops (send (@class ns-array) 'array))114 (do* ((i 1 (1+ i)))115 ((= i 100) p)116 (let* ((tabstop (make-objc-instance117 'ns-text-tab118 :with-type #$NSLeftTabStopType119 :location (* (* i *tab-width*)120 charwidth))))121 (send p :add-tab-stop tabstop)122 (send tabstop 'release)))))123 124 (defun create-text-attributes (&key (font (default-font))125 (line-break-mode :char)126 (color nil))127 (let* ((dict (make-objc-instance128 'ns-mutable-dictionary129 :with-capacity (if color 3 2))))130 (send dict 'retain)131 (send dict132 :set-object (create-paragraph-style font line-break-mode)133 :for-key #@"NSParagraphStyle")134 (send dict :set-object font :for-key #@"NSFont")135 (when color136 (send dict :set-object color :for-key #@"NSColor"))137 dict))138 75 139 76 140 77 (defclass lisp-editor-window-controller (ns:ns-window-controller) 141 ((textview :foreign-type :id) ;The (primary) textview 142 (packagename :foreign-type :id) ;Textfield for package name display 143 (echoarea :foreign-type :id) ;Textfield for message display. 144 (history-count :foreign-type :int) ;current history count (for prev/next) 145 (prev-history-count :foreign-type :int) ;value of history-count before last cmd 146 ) 78 () 147 79 (:metaclass ns:+ns-object)) 148 80 149 (define-objc-method ((:void :display-echo-area contents) lisp-editor-window-controller)150 (send (slot-value self 'echoarea) :set-string-value contents))151 152 (define-objc-method ((:void clear-echo-area)153 lisp-editor-window-controller)154 (send (slot-value self 'echoarea) :set-string-value #@""))155 156 (define-objc-method ((:void :display-package-name name)157 lisp-editor-window-controller)158 (send (slot-value self 'packagename) :set-string-value name))159 160 (defun shortest-package-name (package)161 (let* ((shortest (package-name package))162 (shortest-len (length shortest)))163 (declare (fixnum shortest-len))164 (dolist (nick (package-nicknames package) shortest)165 (let* ((nicklen (length nick)))166 (declare (fixnum nicklen))167 (if (< nicklen shortest-len)168 (setq shortest-len nicklen shortest nick))))))169 170 (define-objc-method ((:void update-package-name) lisp-editor-window-controller)171 (let* ((info (info-from-controller self))172 (package (and info (getf (cocoa-editor-info-modeline-plist info)173 :package)))174 (name (if (and package (typep package 'package))175 (shortest-package-name package)176 "#<PACKAGE unset>")))177 (with-cstrs ((name name))178 (send self179 :display-package-name (send (@class ns-string)180 :string-with-c-string name)))))181 81 182 82 ;;; The LispEditorWindowController is the textview's "delegate": it … … 184 84 ;;; perform actions on behalf of the textview. 185 85 186 ;;; Action methods implemented by the controller (in its role as the187 ;;; textview's delegate).188 189 ;;; If the first line of the buffer contains text between a pair of190 ;;; "-*-"s, treat the line as an attribute line.191 (define-objc-method ((:void :range-for-modeline-in-text-view tv192 :result ((* :<NSR>ange) r))193 lisp-editor-window-controller)194 (let* ((textstring (send tv 'string)))195 (slet ((linerange196 (send textstring :line-range-for-range (ns-make-range 0 0))))197 (when (> (pref linerange :<NSR>ange.length) 0)198 (decf (pref linerange :<NSR>ange.length)))199 (slet ((matchrange1200 (send textstring201 :range-of-string #@"-*-"202 :options 0203 :range linerange)))204 (rlet ((matchrange2 :<NSR>ange))205 (if (and (> (pref matchrange1 :<NSR>ange.length) 0)206 (progn207 (incf (pref matchrange1 :<NSR>ange.location)208 (pref matchrange1 :<NSR>ange.length))209 (setf (pref matchrange1 :<NSR>ange.length)210 (- (pref linerange :<NSR>ange.length)211 (pref matchrange1 :<NSR>ange.location)))212 (send/stret matchrange2 textstring213 :range-of-string #@"-*-"214 :options 0215 :range matchrange1)216 (> (pref matchrange2 :<NSR>ange.length) 0)))217 (setf (pref r :<NSR>ange.location)218 (pref matchrange1 :<NSR>ange.location)219 (pref r :<NSR>ange.length)220 (- (pref matchrange2 :<NSR>ange.location)221 (pref r :<NSR>ange.location)))222 (setf (pref r :<NSR>ange.location) 0223 (pref r :<NSR>ange.length) 0)))))))224 225 ;;; Return a list whose elements are of the form:226 ;;; (opt-name-keyword . (opt-value-start . opt-value-end))227 ;;; for each option. Options are separated colons semicolons;228 ;;; option names are separated from option values by colons.229 (defun extract-modeline-components (string)230 (let* ((start 0)231 (end (length string))232 (options ()))233 (if (find #\: string)234 (block parse-options235 (do* ((opt-start start (1+ semi))236 semi237 colon)238 (nil)239 (setq colon (position #\: string :start opt-start :end end))240 (unless colon241 (return nil))242 (setq semi (or (position #\; string :start colon :end end) end))243 (push244 (cons245 (intern246 (nstring-upcase (string-trim '(#\space #\tab)247 (subseq string opt-start colon)))248 *keyword-package*)249 (cons250 (do* ((i (1+ colon) (1+ i)))251 ((= i semi) (return-from parse-options nil))252 (unless (whitespacep (schar string i))253 (return i)))254 (do* ((i semi j)255 (j (1- i) (1- j)))256 (())257 (unless (whitespacep (schar string j))258 (return i)))))259 options)260 (when (= semi end) (return options)))))))261 262 (defun process-modeline-components (components info)263 (let* ((plist ()))264 (dolist (c components (setf (cocoa-editor-info-modeline-plist info) plist))265 (let* ((indicator (car c))266 (value (cdr c)))267 (case indicator268 (:package (let* ((spec (let* ((*package* *keyword-package*))269 (ignore-errors (read-from-string value)))))270 (when spec271 (let* ((pkg (ignore-errors (find-package272 (if (atom spec)273 spec274 (car spec))))))275 (if pkg276 (setf (getf plist indicator) pkg))))))277 (t (setf (getf plist indicator) value)))))))278 279 (define-objc-method ((:id :reparse-modeline tv)280 lisp-editor-window-controller)281 (unless (%null-ptr-p tv)282 (let* ((info (info-from-controller self)))283 (when info284 (let* ((textstring (send tv 'string)))285 (rlet ((modelinerange :<NSR>ange))286 (send self287 :range-for-modeline-in-text-view tv288 :result modelinerange)289 (unless (zerop (pref modelinerange :<NSR>ange.length))290 (let* ((string (lisp-string-from-nsstring291 (send textstring292 :substring-with-range modelinerange)))293 (components294 (mapcar #'(lambda (x)295 (destructuring-bind (name start . end) x296 (cons name297 (subseq string start end))))298 (extract-modeline-components string))))299 (process-modeline-components components info)300 (send self 'update-package-name))))))))301 self)302 303 304 (define-objc-method ((:id :add-modeline tv)305 lisp-editor-window-controller)306 (let* ((textstring (send tv 'string)))307 (rlet ((modelinerange :<NSR>ange)308 (selrange :<NSR>ange))309 (send self :range-for-modeline-in-text-view tv :result modelinerange)310 (when (= (pref modelinerange :<NSR>ange.length) 0)311 (let* ((info (info-from-document self))312 (package (or (if info313 (getf314 :package315 (cocoa-editor-info-modeline-plist info)))316 (symbol-value-in-top-listener-process317 '*package*)318 *package*))319 (package-name (package-name package))320 (namelen (length package-name)))321 (with-cstrs ((pname package-name))322 (with-nsstr (nsstr pname namelen)323 (let* ((proto (send (@class ns-string)324 :string-with-format325 #@";;;-*- Mode: LISP; Package: %@ -*-326 "327 (:id nsstr))))328 (send tv :set-selected-range (ns-make-range 0 0))329 (send tv :insert-text proto)330 (setf (pref modelinerange :<NSR>ange.location)331 6332 (pref modelinerange :<NSR>ange.length)333 (- (send proto 'length) (+ 6 1 3))))))))334 (let* ((components (extract-modeline-components335 (lisp-string-from-nsstring336 (send textstring337 :substring-with-range modelinerange))))338 (package-component (assoc :PACKAGE components)))339 (if package-component340 (destructuring-bind (start . end) (cdr package-component)341 (setf (pref selrange :<NSR>ange.location)342 (+ start (pref modelinerange :<NSR>ange.location))343 (pref selrange :<NSR>ange.length)344 (- end start)))345 (setf (pref selrange :<NSR>ange.location)346 (pref modelinerange :<NSR>ange.location)347 (pref selrange :<NSR>ange.length)348 0))349 (send tv :set-selected-range selrange)350 (send tv :scroll-range-to-visible selrange)351 (send tv 'display))))352 self)353 354 ;;; Interrupt/abort something. When that means something ...355 (define-objc-method ((:id :interrupt tv) lisp-editor-window-controller)356 (declare (ignore tv))357 self)358 359 360 (define-objc-method ((:id :eval-defun tv)361 lisp-editor-window-controller)362 (rlet ((workrange :<NSR>ange))363 (let* ((textbuf (send tv 'string))364 (textlen (send textbuf 'length)))365 (slet ((defunrange (send tv 'selected-range)))366 (let* ((pointpos (pref defunrange :<NSR>ange.location)))367 (if (> (pref defunrange :<NSR>ange.length) 0)368 (progn369 (setf (pref workrange :<NSR>ange.location)370 (pref defunrange :<NSR>ange.location)371 (pref workrange :<NSR>ange.length)372 (pref defunrange :<NSR>ange.length))373 (multiple-value-bind (ok non-wsp)374 (balanced-expressions-in-range-forward workrange textbuf)375 (unless (and ok non-wsp)376 (setf (pref defunrange :<NSR>ange.length) 0))))377 (let* ((defun-start (previous-start-of-defun textbuf pointpos)))378 (when defun-start379 (setf (pref workrange :<NSR>ange.location) defun-start380 (pref workrange :<NSR>ange.length) (- textlen defun-start))381 (if (forward-over-list workrange textbuf)382 (setf (pref defunrange :<NSR>ange.location)383 defun-start384 (pref defunrange :<NSR>ange.length)385 (- (1+ (pref workrange :<NSR>ange.location))386 defun-start))387 (setf (pref defunrange :<NSR>ange.length)388 0)))))389 (if (and (> (pref defunrange :<NSR>ange.length) 0)390 #|(> pointpos (+ (pref defunrange :<NSR>ange.location)391 (pref defunrange :<NSR>ange.length)))|#)392 (send-to-top-listener393 (info-from-controller self)394 (send textbuf :substring-with-range defunrange))395 (#_NSBeep))))))396 self)397 398 399 ;;; Also a delegate method400 (define-objc-method ((:<BOOL> :text-view tv401 :do-command-by-selector (:<SEL> selector))402 lisp-editor-window-controller)403 (with-slots (history-count prev-history-count) self404 (setq prev-history-count history-count405 history-count 0))406 (if (not (send self :responds-to-selector selector))407 #$NO408 (progn409 (send self :perform-selector selector :with-object tv)410 #$YES)))411 86 412 87 … … 415 90 416 91 (defclass lisp-editor-document (ns:ns-document) 417 ((text-view :foreign-type :id) 418 (filedata :foreign-type :id) 419 (packagename :foreign-type :id) 420 (echoarea :foreign-type :id)) 92 ((textstorage :foreign-type :id)) 421 93 (:metaclass ns:+ns-object)) 422 94 423 (define-objc-method ((:id window-nib-name) lisp-editor-document) 424 #@"lispeditor") 95 (define-objc-method ((:id init) lisp-editor-document) 96 (let* ((doc (send-super 'init))) 97 (setf (slot-value doc 'textstorage) 98 (make-textstorage-for-hemlock-buffer 99 (hemlock-buffer-from-nsstring 100 #@"" 101 (lisp-string-from-nsstring (send doc 'display-name)) 102 "Lisp"))) 103 doc)) 104 425 105 426 106 (define-objc-method ((:void make-window-controllers) lisp-editor-document) 427 107 (let* ((controller (make-objc-instance 428 108 'lisp-editor-window-controller 429 :with-window -nib-name (send self 'window-nib-name)430 :owner self)))109 :with-window (%hemlock-frame-for-textstorage 110 (slot-value self 'textstorage) nil nil)))) 431 111 (send self :add-window-controller controller) 432 112 (send controller 'release))) 433 113 114 (define-objc-method ((:<BOOL> :load-data-representation data :of-type type) 115 lisp-editor-document) 116 (declare (ignorable data type)) 117 (let* ((nsstring 118 nil) 119 434 120 435 121 (define-objc-method ((:id :data-representation-of-type ((* :char) type)) … … 441 127 442 128 443 (define-objc-method ((:<BOOL> :load-data-representation data444 :of-type type)445 lisp-editor-document)446 (declare (ignorable type))447 (setf (slot-value self 'filedata) data)448 (not (%null-ptr-p data)))449 129 130 #| 450 131 (define-objc-method ((:void :window-controller-did-load-nib acontroller) 451 132 lisp-editor-document) … … 488 169 :with-data filedata 489 170 :encoding #$NSASCIIStringEncoding)) 490 (send acontroller :reparse-modeline text-view))))) 171 )))) 172 |# 491 173 492 174 (define-objc-method ((:void close) lisp-editor-document) … … 502 184 (delete info *open-editor-documents*)))))) 503 185 504 ;;; Syntax utilities505 506 ;;; If range is non-empty, return the current char without affecting range.507 (defun current-char-in-range (rangeptr textbuf)508 (let* ((width (pref rangeptr :<NSR>ange.length)))509 (declare (ingeger width))510 (if (zerop width)511 nil512 (code-char513 (send textbuf514 :character-at-index (pref rangeptr :<NSR>ange.location))))))515 516 (defun next-char-in-range (rangeptr textbuf)517 (let* ((width (pref rangeptr :<NSR>ange.length)))518 (declare (integer width))519 (unless (zerop width)520 (setf (pref rangeptr :<NSR>ange.length) (1- width)521 (pref rangeptr :<NSR>ange.location)522 (1+ (pref rangeptr :<NSR>ange.location)))523 (current-char-in-range rangeptr textbuf))))524 525 ;;; Try to extend the range backward, unless its location is526 ;;; already at (or below) limit.527 (defun prev-char-in-range (rangeptr textbuf &optional (limit 0))528 (let* ((pos (pref rangeptr :<NSR>ange.location)))529 (when (> pos limit)530 (setf (pref rangeptr :<NSR>ange.location)531 (1- (pref rangeptr :<NSR>ange.location))532 (pref rangeptr :<NSR>ange.length)533 (1+ (pref rangeptr :<NSR>ange.length)))534 (current-char-in-range rangeptr textbuf))))535 536 (defun forward-over-#-comment (rangeptr textbuf)537 ;; We've just read a "#|" : the range points to the |. Return538 ;; T if the number of open #| comments reaches 0 (with the range539 ;; pointing to the outermost closing #), NIL if we hit EOF first.540 (do* ((count 1)541 (pending-open nil)542 (pending-close nil))543 ((zerop count) t)544 (declare (fixnum count)) ; Pretty unlikely not to be.545 (case (next-char-in-range rangeptr textbuf)546 ((nil) (return))547 (#\| (if pending-open548 (progn (incf count) (setq pending-open nil))549 (setq pending-close t)))550 (#\# (if pending-close551 (progn (decf count) (setq pending-close nil))552 (setq pending-open t))))))553 554 (defun backward-over-#-comment (rangeptr textbuf &optional (limit 0))555 ;; We've just read a trailing "|#" : the range points to the |. Return556 ;; T if the number of open #| comments reaches 0 (with the range557 ;; pointing to the outermost closing #), NIL if we hit EOF first.558 (do* ((count 1)559 (pending-open nil)560 (pending-close nil))561 ((zerop count) t)562 (declare (fixnum count)) ; Pretty unlikely not to be.563 (case (prev-char-in-range rangeptr textbuf limit)564 ((nil) (return))565 (#\| (if pending-open566 (progn (incf count) (setq pending-open nil))567 (setq pending-close t)))568 (#\# (if pending-close569 (progn (decf count) (setq pending-close nil))570 (setq pending-open t))))))571 572 (defun forward-until-match (rangeptr textbuf matchchar)573 (do* ((ch (next-char-in-range rangeptr textbuf)574 (next-char-in-range rangeptr textbuf)))575 ((eql ch matchchar) t)576 (when (null ch)577 (return nil))))578 579 ;;; Range points to #\; . Win if we find a newline before EOF; leave580 ;;; range pointing to newline on success.581 (defun forward-over-semi-comment (rangeptr textbuf)582 (forward-until-match rangeptr textbuf #\Newline))583 584 ;;; (Harder to find semi-comments backward ...)585 586 ;;; Range points to #\|; find match & leave range pointing there.587 (defun forward-over-multi-escape (rangeptr textbuf)588 (forward-until-match rangeptr textbuf #\|))589 590 ;;; Advance over a string. The range points to a leading (unescaped)591 ;;; #\". If we find a trailing unescaped #\", return T with the592 ;;; range pointing to it, else return NIL.593 (defun forward-over-string (rangeptr textbuf)594 (do* ((ch (next-char-in-range rangeptr textbuf)595 (next-char-in-range rangeptr textbuf)))596 ((null ch))597 (if (eql ch #\")598 (return t)599 (if (eql ch #\\)600 (when (null (next-char-in-range rangeptr textbuf))601 (return nil))))))602 603 ;;; The range points to the trailing unescaped #\". Back up until604 ;;; we find a matching unescaped #\". (We have to back up an extra605 ;;; char, then move forward if the extra char wasn't a #\\.) Return606 ;;; T (with the range pointing at the leading #\"), else NIL.607 (defun backward-over-string (rangeptr textbuf &optional (limit 0))608 (do* ((ch (prev-char-in-range rangeptr textbuf limit)609 (prev-char-in-range rangeptr textbuf limit)))610 ((null ch) nil)611 (when (eql ch #\")612 (setq ch (prev-char-in-range rangeptr textbuf limit))613 (if (null ch)614 (return)615 (unless (eql ch #\\)616 (next-char-in-range rangeptr textbuf)617 (return t))))))618 619 ;;; Point the range to the first non-whitespace character.620 (defun forward-skip-whitespace (rangeptr textbuf)621 (do* ((ch (current-char-in-range rangeptr textbuf)622 (next-char-in-range rangeptr textbuf)))623 ((null ch))624 (unless (whitespacep ch)625 (return t))))626 627 ;;; Range points to list-open character (e.g., open-paren.) Return628 ;;; T if we can advance so that range points to list-close char,629 ;;; seeing nothing but balanced expressions along the way.630 (defun forward-over-list (rangeptr textbuf &optional (close #\)))631 (loop632 (let* ((ch (next-char-in-range rangeptr textbuf)))633 (if (eql ch close)634 (return t)635 (case ch636 ((nil #\) #\] #\}) (return nil))637 ;; I suppose that this could be made non-recursive.638 ;; Anything nested more than a dozen or two levels639 ;; deep probably means that the cat fell asleep640 ;; on the keyboard ...641 (#\( (unless (forward-over-list rangeptr textbuf #\))642 (return nil)))643 (#\[ (unless (forward-over-list rangeptr textbuf #\])644 (return nil)))645 (#\{ (unless (forward-over-list rangeptr textbuf #\})646 (return nil)))647 648 (#\# (setq ch (next-char-in-range rangeptr textbuf))649 (if (or (null ch)650 (and (eql ch #\|)651 (not (forward-over-#-comment rangeptr textbuf))))652 (return nil)))653 (#\" (unless (forward-over-string rangeptr textbuf)654 (return nil)))655 (#\| (unless (forward-over-multi-escape rangeptr textbuf))656 (return nil))657 (#\\ (if (null (next-char-in-range rangeptr textbuf))658 (return nil)))659 (#\; (unless (forward-over-semi-comment rangeptr textbuf)660 (return nil))))))))661 662 ;;; Return (values T T) if all expressions in range are properly663 ;;; balanced and something other than semantic whitespace was664 ;;; seen, else return (values T NIL) if all expressions are665 ;;; balanced, else return (values NIL NIL) if some expression666 ;;; is unterminated but nothing's prematurely terminated, else667 ;;; return (values NIL T)668 (defun balanced-expressions-in-range-forward (rangeptr textbuf)669 (do* ((ch (current-char-in-range rangeptr textbuf)670 (next-char-in-range rangeptr textbuf))671 (seen-something-interesting nil))672 ((null ch) (return (values t seen-something-interesting)))673 (case ch674 ((#\) #\] #\}) (return (values nil t)))675 (#\( (if (forward-over-list rangeptr textbuf #\))676 (setq seen-something-interesting t)677 (return (values nil nil))))678 (#\[ (if (forward-over-list rangeptr textbuf #\])679 (setq seen-something-interesting t)680 (return (values nil nil))))681 (#\{ (if (forward-over-list rangeptr textbuf #\})682 (setq seen-something-interesting t)683 (return (values nil nil))))684 (#\" (if (forward-over-string rangeptr textbuf)685 (setq seen-something-interesting t)686 (return (values nil nil))))687 (#\| (if (forward-over-multi-escape rangeptr textbuf)688 (setq seen-something-interesting t)689 (return (values nil nil))))690 (#\; (unless (forward-over-semi-comment rangeptr textbuf)691 (return (values nil nil))))692 (#\# (let* ((nextch (next-char-in-range rangeptr textbuf)))693 (if (null nextch)694 (return (values nil nil))695 (if (eql nextch #\|)696 (unless (forward-over-#-comment rangeptr textbuf)697 (return (values nil nil)))))))698 (t699 (unless seen-something-interesting700 (unless (whitespacep ch)701 (setq seen-something-interesting t)))))))702 703 (defun previous-start-of-defun (textbuf startpos)704 (rlet ((linerange :<NSR>ange)705 (posrange :<NSR>ange :length 0))706 (do* ((pos startpos (1- (pref linerange :<NSR>ange.location))))707 ((< pos 0))708 (setf (pref posrange :<NSR>ange.location) pos)709 (send/stret linerange textbuf :line-range-for-range posrange)710 (if (eql (current-char-in-range linerange textbuf) #\()711 (return (pref linerange :<NSR>ange.location))))))712 186 713 187 (provide "COCOA-EDITOR") -
trunk/ccl/examples/cocoa-listener.lisp
r430 r568 22 22 (type list *open-editor-documents*)) 23 23 24 #-hemlock 25 (progn 24 26 (defun new-listener-process (procname input-fd output-fd) 25 27 (make-mcl-listener-process … … 335 337 336 338 337 (defloadvar *cocoa-listener-count* 0)339 (defloadvar *cocoa-listener-count* 17) 338 340 339 341 (define-objc-method ((:void :window-controller-did-load-nib acontroller) … … 389 391 390 392 393 ); #-hemlock -
trunk/ccl/examples/cocoa-window.lisp
r541 r568 267 267 #'cocoa-startup) 268 268 (toplevel))))) 269 270 (defparameter *default-font-name* "Courier") 271 (defparameter *default-font-size* 12.0e0) 272 273 274 ;;; Try to find the specified font. If it doesn't exist (or isn't 275 ;;; fixed-pitch), try to find a fixed-pitch font of the indicated size. 276 (defun default-font (&key (name *default-font-name*) 277 (size *default-font-size*)) 278 (setq size (float size 0.0f0)) 279 (with-cstrs ((name name)) 280 (with-autorelease-pool 281 (rletz ((matrix (:array :float 6))) 282 (setf (%get-single-float matrix 0) size 283 (%get-single-float matrix 12) size) 284 (let* ((fontname (send (@class ns-string) :string-with-c-string name)) 285 (font (send (@class ns-font) 286 :font-with-name fontname :matrix matrix))) 287 (if (or (%null-ptr-p font) 288 (and 289 (not (send font 'is-fixed-pitch)) 290 (not (eql #$YES (objc-message-send font "_isFakeFixedPitch" :<BOOL>))))) 291 (setq font (send (@class ns-font) 292 :user-fixed-pitch-font-of-size size))) 293 font))))) 294 295 (defparameter *tab-width* 8) 296 297 ;;; Create a paragraph style, mostly so that we can set tabs reasonably. 298 (defun create-paragraph-style (font line-break-mode) 299 (let* ((p (make-objc-instance 'ns-mutable-paragraph-style)) 300 (charwidth (send (send font 'screen-font) 301 :width-of-string #@" "))) 302 (send p 303 :set-line-break-mode 304 (ecase line-break-mode 305 (:char #$NSLineBreakByCharWrapping) 306 (:word #$NSLineBreakByWordWrapping) 307 ;; This doesn't seem to work too well. 308 ((nil) #$NSLineBreakByClipping))) 309 ;; Clear existing tab stops. 310 (send p :set-tab-stops (send (@class ns-array) 'array)) 311 (do* ((i 1 (1+ i))) 312 ((= i 100) p) 313 (let* ((tabstop (make-objc-instance 314 'ns-text-tab 315 :with-type #$NSLeftTabStopType 316 :location (* (* i *tab-width*) 317 charwidth)))) 318 (send p :add-tab-stop tabstop) 319 (send tabstop 'release))))) 320 321 (defun create-text-attributes (&key (font (default-font)) 322 (line-break-mode :char) 323 (color nil)) 324 (let* ((dict (make-objc-instance 325 'ns-mutable-dictionary 326 :with-capacity (if color 3 2)))) 327 (send dict 'retain) 328 (send dict 329 :set-object (create-paragraph-style font line-break-mode) 330 :for-key #@"NSParagraphStyle") 331 (send dict :set-object font :for-key #@"NSFont") 332 (when color 333 (send dict :set-object color :for-key #@"NSColor")) 334 dict)) -
trunk/ccl/examples/hemlock-textstorage.lisp
r566 r568 261 261 :font (default-font 262 262 :name "Courier New Bold Italic" 263 :size 9.0)))263 :size 10.0))) 264 264 265 265 (defun buffer-for-modeline-view (mv) … … 364 364 365 365 366 (defun make-scrolling-text-view-for- buffer (bufferx y width height)366 (defun make-scrolling-text-view-for-textstorage (textstorage x y width height) 367 367 (slet ((contentrect (ns-make-rect x y width height))) 368 (let* ((textstorage (make-textstorage-for-hemlock-buffer buffer)) 369 (scrollview (send (make-objc-instance 368 (let* ((scrollview (send (make-objc-instance 370 369 'modeline-scroll-view 371 370 :with-frame contentrect) 'autorelease))) … … 413 412 414 413 415 (defun make-scrolling-textview-for-pane (pane buffer)414 (defun make-scrolling-textview-for-pane (pane textstorage) 416 415 (slet ((contentrect (send (send pane 'content-view) 'frame))) 417 416 (multiple-value-bind (tv scrollview) 418 (make-scrolling-text-view-for- buffer419 buffer417 (make-scrolling-text-view-for-textstorage 418 textstorage 420 419 (pref contentrect :<NSR>ect.origin.x) 421 420 (pref contentrect :<NSR>ect.origin.y) … … 470 469 (send w :make-key-and-order-front nil)) 471 470 472 (defun new-hemlock-document-window ( title&key473 474 475 476 477 478 479 480 481 482 483 484 485 471 (defun new-hemlock-document-window (&key 472 (x 0.0) 473 (y 0.0) 474 (height 200.0) 475 (width 500.0) 476 (closable t) 477 (iconifyable t) 478 (metal t) 479 (expandable t) 480 (backing :buffered) 481 (defer nil) 482 (accepts-mouse-moved-events nil) 483 (auto-display t) 484 (activate t)) 486 485 (rlet ((frame :<NSR>ect :origin.x (float x) :origin.y (float y) :size.width (float width) :size.height (float height))) 487 486 (let* ((stylemask … … 502 501 :backing backing-type 503 502 :defer defer))) 504 (send w :set-title (%make-nsstring title))505 503 (setf (get-cocoa-window-flag w :accepts-mouse-moved-events) 506 504 accepts-mouse-moved-events … … 523 521 524 522 525 (defun textview-for-hemlock-buffer (b) 526 (process-interrupt 527 *cocoa-event-process* 528 #'(lambda () 529 (let* ((name (hi::buffer-name b))) 530 (multiple-value-bind (window pane) 531 (new-hemlock-document-window name :activate nil) 532 (let* ((tv (make-scrolling-textview-for-pane pane b))) 533 (multiple-value-bind (height width) 534 (size-of-char-in-font (default-font)) 535 (size-textview-containers tv height width 24 80)) 536 (activate-window window) 537 tv)))))) 523 (defun textpane-for-textstorage (ts) 524 (let* ((pane (nth-value 525 1 526 (new-hemlock-document-window :activate nil))) 527 (tv (make-scrolling-textview-for-pane pane ts))) 528 (multiple-value-bind (height width) 529 (size-of-char-in-font (default-font)) 530 (size-textview-containers tv height width 24 80)) 531 pane)) 538 532 539 533 … … 541 535 (hemlock::find-file-buffer path)) 542 536 543 (defun hemlock-buffer-from-nsstring (nsstring name )544 (let* ((buffer (hi::make-buffer name )))537 (defun hemlock-buffer-from-nsstring (nsstring name &rest modes) 538 (let* ((buffer (hi::make-buffer name :modes modes))) 545 539 (hi::delete-region (hi::buffer-region buffer)) 546 540 (hi::modifying-buffer buffer) … … 584 578 (setq previous line)))) 585 579 (setq line-start (pref line-end-index :unsigned)))))))) 580 (setf (hi::buffer-modified buffer) nil) 586 581 buffer)) 587 582 … … 590 585 (#_NSBeep))) 591 586 587 ;;; This function must run in the main event thread. 588 (defun %hemlock-frame-for-textstorage (ts title activate) 589 (let* ((pane (textpane-for-textstorage ts)) 590 (w (send pane 'window))) 591 (when title (send w :set-title (%make-nsstring title))) 592 (when activate (activate-window w)) 593 w)) 594 595 (defun hemlock-frame-for-textstorage (ts title activate) 596 (process-interrupt *cocoa-event-process* 597 #'%hemlock-frame-for-textstorage 598 ts title activate)) 599 600 592 601 (defun edit (path) 593 (textview-for-hemlock-buffer (read-file-to-hemlock-buffer path))) 602 (let* ((buffer (read-file-to-hemlock-buffer path)) 603 (textstorage (make-textstorage-for-hemlock-buffer buffer))) 604 (hemlock-frame-for-textstorage textstorage (hi::buffer-name buffer) t))) 594 605 595 606 (defun for-each-textview-using-storage (textstorage f)
Note:
See TracChangeset
for help on using the changeset viewer.
