Changeset 6589
- Timestamp:
- May 20, 2007, 9:16:59 AM (18 years ago)
- File:
-
- 1 edited
-
branches/ide-1.0/ccl/examples/cocoa-editor.lisp (modified) (22 diffs)
Legend:
- Unmodified
- Added
- Removed
-
branches/ide-1.0/ccl/examples/cocoa-editor.lisp
r6251 r6589 161 161 (when buffer-p (setf (buffer-cache-buffer d) buffer)) 162 162 (let* ((hi::*buffer-gap-context* (hi::buffer-gap-context buffer)) 163 163 (workline (hi::mark-line 164 164 (hi::buffer-start-mark buffer)))) 165 165 (setf (buffer-cache-buflen d) (hemlock-buffer-length buffer) … … 177 177 (incf (buffer-cache-workline-offset display) n) 178 178 (when (>= (+ (buffer-cache-workline-offset display) 179 (buffer-cache-workline-length display))180 pos)179 (buffer-cache-workline-length display)) 180 pos) 181 181 (setf (buffer-cache-workline-length display) 182 182 (hi::line-length (buffer-cache-workline display))))) … … 192 192 (defun update-line-cache-for-index (cache index) 193 193 (let* ((buffer (buffer-cache-buffer cache)) 194 195 194 (hi::*buffer-gap-context* (hi::buffer-gap-context buffer)) 195 (line (or 196 196 (buffer-cache-workline cache) 197 197 (progn … … 229 229 (defun hemlock-char-at-index (cache index) 230 230 (let* ((hi::*buffer-gap-context* 231 231 (hi::buffer-gap-context (buffer-cache-buffer cache)))) 232 232 (multiple-value-bind (line idx) (update-line-cache-for-index cache index) 233 233 (let* ((len (hemlock::line-length line))) … … 240 240 (defun move-hemlock-mark-to-absolute-position (mark cache abspos) 241 241 (let* ((hi::*buffer-gap-context* 242 242 (hi::buffer-gap-context (buffer-cache-buffer cache)))) 243 243 (multiple-value-bind (line idx) (update-line-cache-for-index cache abspos) 244 244 #+debug 245 245 (#_NSLog #@"Moving point from current pos %d to absolute position %d" 246 247 246 :int (mark-absolute-position mark) 247 :int abspos) 248 248 (hemlock::move-to-position mark idx line) 249 249 #+debug … … 255 255 (defun mark-absolute-position (mark) 256 256 (let* ((pos (hi::mark-charpos mark)) 257 (hi::*buffer-gap-context* (hi::buffer-gap-context (hi::line-%buffer258 257 (hi::*buffer-gap-context* 258 (hi::buffer-gap-context (hi::line-%buffer (hi::mark-line mark))))) 259 259 (do* ((line (hi::line-previous (hi::mark-line mark)) 260 260 (hi::line-previous line))) … … 289 289 (length (ns:ns-range-length r)) 290 290 (hi::*buffer-gap-context* 291 291 (hi::buffer-gap-context (buffer-cache-buffer cache)))) 292 292 #+debug 293 293 (#_NSLog #@"get characters: %d/%d" … … 356 356 (flag :<BOOL>)) 357 357 (let* ((buffer (buffer-cache-buffer (hemlock-buffer-string-cache self))) 358 358 (hi::*buffer-gap-context* (hi::buffer-gap-context buffer)) 359 359 (external-format (if buffer (hi::buffer-external-format buffer ))) 360 360 (raw-length (if buffer (hemlock-buffer-length buffer) 0))) … … 533 533 (- endpos startpos) 534 534 (hi::font-mark-font start)))))) 535 #+debug 535 #+debug 536 536 (#_NSLog #@"Start = %d, len = %d, style = %d" 537 537 :int start :int len :int style) … … 545 545 (let* ((cache (hemlock-buffer-string-cache (#/string self))) 546 546 (buffer (if cache (buffer-cache-buffer cache))) 547 548 547 (hi::*buffer-gap-context* (hi::buffer-gap-context buffer)) 548 (location (pref r :<NSR>ange.location)) 549 549 (length (pref r :<NSR>ange.length)) 550 550 (mark (hi::buffer-%mark buffer)) … … 774 774 (let* ((index (ns:ns-range-location proposed)) 775 775 (length (ns:ns-range-length proposed))) 776 (when (and (eql 0 length); not extending existing selection777 (not (eql g #$NSSelectByCharacter)))778 (let* ((textstorage (#/textStorage self))779 (cache (hemlock-buffer-string-cache (#/string textstorage)))780 (buffer (if cache (buffer-cache-buffer cache))))781 (when (and buffer (string= (hi::buffer-major-mode buffer) "Lisp"))782 (let* ((hi::*buffer-gap-context* (hi::buffer-gap-context buffer)))783 (hi::with-mark ((m1 (hi::buffer-point buffer)))784 (move-hemlock-mark-to-absolute-position m1 cache index)785 (hemlock::pre-command-parse-check m1)786 (when (hemlock::valid-spot m1 nil)787 (cond ((eql (hi::next-character m1) #\()788 (hi::with-mark ((m2 m1))789 (when (hemlock::list-offset m2 1)790 (ns:init-ns-range r index (- (mark-absolute-position m2) index))791 (return-from HANDLED r))))792 ((eql (hi::previous-character m1) #\))793 (hi::with-mark ((m2 m1))794 (when (hemlock::list-offset m2 -1)795 (ns:init-ns-range r (mark-absolute-position m2) (- index (mark-absolute-position m2)))796 (return-from HANDLED r))))))))))))797 (call-next-method proposed g)798 #+debug799 (#_NSLog #@"range = %@, proposed = %@, granularity = %d"800 :address (#_NSStringFromRange r)801 :address (#_NSStringFromRange proposed)802 :<NSS>election<G>ranularity g))))776 (when (and (eql 0 length) ; not extending existing selection 777 (not (eql g #$NSSelectByCharacter))) 778 (let* ((textstorage (#/textStorage self)) 779 (cache (hemlock-buffer-string-cache (#/string textstorage))) 780 (buffer (if cache (buffer-cache-buffer cache)))) 781 (when (and buffer (string= (hi::buffer-major-mode buffer) "Lisp")) 782 (let* ((hi::*buffer-gap-context* (hi::buffer-gap-context buffer))) 783 (hi::with-mark ((m1 (hi::buffer-point buffer))) 784 (move-hemlock-mark-to-absolute-position m1 cache index) 785 (hemlock::pre-command-parse-check m1) 786 (when (hemlock::valid-spot m1 nil) 787 (cond ((eql (hi::next-character m1) #\() 788 (hi::with-mark ((m2 m1)) 789 (when (hemlock::list-offset m2 1) 790 (ns:init-ns-range r index (- (mark-absolute-position m2) index)) 791 (return-from HANDLED r)))) 792 ((eql (hi::previous-character m1) #\)) 793 (hi::with-mark ((m2 m1)) 794 (when (hemlock::list-offset m2 -1) 795 (ns:init-ns-range r (mark-absolute-position m2) (- index (mark-absolute-position m2))) 796 (return-from HANDLED r)))))))))))) 797 (call-next-method proposed g) 798 #+debug 799 (#_NSLog #@"range = %@, proposed = %@, granularity = %d" 800 :address (#_NSStringFromRange r) 801 :address (#_NSStringFromRange proposed) 802 :<NSS>election<G>ranularity g)))) 803 803 804 804 … … 1299 1299 (let* ((message (#/objectAtIndex: info 0)) 1300 1300 (signal (#/objectAtIndex: info 1))) 1301 (#_NSLog #@"runErrorSheet: signal = %@" :id signal) 1301 1302 (#_NSBeginAlertSheet #@"Error in Hemlock command processing" ;title 1302 1303 (if (logbitp 0 (random 2)) … … 1313 1314 1314 1315 (objc:defmethod (#/sheetDidEnd:returnCode:contextInfo: :void) ((self hemlock-frame)) 1315 (declare (ignore sheet code info))) 1316 (declare (ignore sheet code info)) 1317 #+debug 1318 (#_NSLog #@"Sheet did end")) 1316 1319 1317 1320 (objc:defmethod (#/sheetDidDismiss:returnCode:contextInfo: :void) 1318 1321 ((self hemlock-frame) sheet code info) 1319 1322 (declare (ignore sheet code)) 1323 #+debug (#_NSLog #@"dismiss sheet: semaphore = %lx" :unsigned-doubleword (#/unsignedLongValue info)) 1320 1324 (ccl::%signal-semaphore-ptr (%int-to-ptr (#/unsignedLongValue info)))) 1321 1325 … … 1325 1329 (sem-value (make-instance 'ns:ns-number 1326 1330 :with-unsigned-long (%ptr-to-int (semaphore.value semaphore))))) 1327 (%stack-block ((paramptrs (ash 2 target::word-shift))) 1328 (setf (%get-ptr paramptrs 0) message 1329 (%get-ptr paramptrs (ash 1 target::word-shift)) sem-value) 1331 #+debug 1332 (#_NSLog #@"created semaphore with value %lx" :address (semaphore.value semaphore)) 1333 (rlet ((paramptrs (:array :id 2))) 1334 (setf (paref paramptrs (:array :id) 0) message 1335 (paref paramptrs (:array :id) 1) sem-value) 1330 1336 (let* ((params (make-instance 'ns:ns-array 1331 1337 :with-objects paramptrs 1332 1338 :count 2)) 1333 (*debug-io* *typeout-stream*))1339 #|(*debug-io* *typeout-stream*)|#) 1334 1340 (stream-clear-output *debug-io*) 1335 1341 (print-call-history :detailed-p nil) … … 1364 1370 (hi::*last-key-event-typed* nil) 1365 1371 (hi::*input-transcript* nil) 1366 1372 (hi::*buffer-gap-context* (hi::buffer-gap-context buffer)) 1367 1373 (hemlock::*target-column* 0) 1368 1374 (hemlock::*last-comment-start* " ") … … 1500 1506 (defun nsstring-to-buffer (nsstring buffer) 1501 1507 (let* ((document (hi::buffer-document buffer)) 1502 1508 (hi::*buffer-gap-context* (hi::buffer-gap-context buffer)) 1503 1509 (region (hi::buffer-region buffer))) 1504 1510 (setf (hi::buffer-document buffer) nil) … … 1521 1527 (let* ((lisp-namestring (native-translated-namestring lisp-pathname)) 1522 1528 (cocoa-pathname (%make-nsstring lisp-namestring)) 1523 1529 (hi::*buffer-gap-context* (hi::buffer-gap-context buffer)) 1524 1530 (data (make-instance 'ns:ns-data 1525 1531 :with-contents-of-file cocoa-pathname)) … … 1767 1773 1768 1774 (defclass hemlock-editor-document (ns:ns-document) 1769 ((textstorage :foreign-type :id)) 1775 ((textstorage :foreign-type :id) 1776 (encoding :foreign-type :<NSS>tring<E>ncoding)) 1770 1777 (:metaclass ns:+ns-object)) 1771 1778 … … 1837 1844 :modes '("Lisp" "Editor"))))) 1838 1845 doc)) 1839 1840 (objc:defmethod (#/readFromFile:ofType: :<BOOL>) 1841 ((self hemlock-editor-document) filename type) 1846 1847 1848 (objc:defmethod (#/readFromURL:ofType:error: :<BOOL>) 1849 ((self hemlock-editor-document) url type (perror (:* :id))) 1842 1850 (declare (ignorable type)) 1843 (let* ((pathname (lisp-string-from-nsstring filename)) 1844 (buffer-name (hi::pathname-to-buffer-name pathname)) 1845 (buffer (or 1846 (hemlock-document-buffer self) 1847 (let* ((b (make-hemlock-buffer buffer-name))) 1848 (setf (hi::buffer-pathname b) pathname) 1849 (setf (slot-value self 'textstorage) 1850 (make-textstorage-for-hemlock-buffer b)) 1851 b))) 1852 (hi::*buffer-gap-context* (hi::buffer-gap-context buffer)) 1853 (data (make-instance 'ns:ns-data :with-contents-of-file filename)) 1854 (string (make-instance 'ns:ns-string 1855 :with-data data 1856 :encoding #$NSASCIIStringEncoding))) 1857 (hi::document-begin-editing self) 1858 (nsstring-to-buffer string buffer) 1859 (let* ((textstorage (slot-value self 'textstorage)) 1860 (display (hemlock-buffer-string-cache (#/string textstorage)))) 1861 (reset-buffer-cache display) 1862 (update-line-cache-for-index display 0) 1863 (textstorage-note-insertion-at-position 1864 textstorage 1865 0 1866 (hemlock-buffer-length buffer))) 1867 (hi::document-end-editing self) 1868 (setf (hi::buffer-modified buffer) nil) 1869 (hi::process-file-options buffer pathname) 1870 t)) 1851 (rlet ((pused-encoding :<NSS>tring<E>ncoding 0)) 1852 (let* ((pathname 1853 (lisp-string-from-nsstring 1854 (if (#/isFileURL url) 1855 (#/path url) 1856 (#/absoluteString url)))) 1857 (buffer-name (hi::pathname-to-buffer-name pathname)) 1858 (buffer (or 1859 (hemlock-document-buffer self) 1860 (let* ((b (make-hemlock-buffer buffer-name))) 1861 (setf (hi::buffer-pathname b) pathname) 1862 (setf (slot-value self 'textstorage) 1863 (make-textstorage-for-hemlock-buffer b)) 1864 b))) 1865 (hi::*buffer-gap-context* (hi::buffer-gap-context buffer)) 1866 (selected-encoding (slot-value (#/sharedDocumentController (find-class 'hemlock-document-controller)) 'last-encoding)) 1867 (string 1868 (if (zerop selected-encoding) 1869 (#/stringWithContentsOfURL:usedEncoding:error: 1870 ns:ns-string 1871 url 1872 pused-encoding 1873 perror) 1874 +null-ptr+))) 1875 (when (%null-ptr-p string) 1876 (if (zerop selected-encoding) 1877 (setq selected-encoding (#/defaultCStringEncoding ns:ns-string))) 1878 (setq string (#/stringWithContentsOfURL:encoding:error: 1879 ns:ns-string 1880 url 1881 selected-encoding 1882 perror))) 1883 (unless (%null-ptr-p string) 1884 (with-slots (encoding) self (setq encoding selected-encoding)) 1885 (hi::document-begin-editing self) 1886 (nsstring-to-buffer string buffer) 1887 (let* ((textstorage (slot-value self 'textstorage)) 1888 (display (hemlock-buffer-string-cache (#/string textstorage)))) 1889 (reset-buffer-cache display) 1890 (update-line-cache-for-index display 0) 1891 (textstorage-note-insertion-at-position 1892 textstorage 1893 0 1894 (hemlock-buffer-length buffer))) 1895 (hi::document-end-editing self) 1896 (setf (hi::buffer-modified buffer) nil) 1897 (hi::process-file-options buffer pathname) 1898 t)))) 1871 1899 1872 1900 #+experimental … … 1967 1995 1968 1996 1969 (defun initialize-user-interface () 1970 (#/sharedPanel preferences-panel) 1971 (update-cocoa-defaults) 1972 (make-editor-style-map)) 1997 1973 1998 1974 1999 (defun hi::scroll-window (textpane n) … … 1981 2006 1982 2007 2008 (defclass hemlock-document-controller (ns:ns-document-controller) 2009 ((last-encoding :foreign-type :<NSS>tring<E>ncoding)) 2010 (:metaclass ns:+ns-object)) 2011 2012 (defloadvar *hemlock-document-controller* nil "Shared document controller") 2013 2014 (objc:defmethod #/sharedDocumentController ((self +hemlock-document-controller)) 2015 (or *hemlock-document-controller* 2016 (setq *hemlock-document-controller* (#/init (#/alloc self))))) 2017 2018 (objc:defmethod #/init ((self hemlock-document-controller)) 2019 (if *hemlock-document-controller* 2020 (progn 2021 (#/release self) 2022 *hemlock-document-controller*) 2023 (prog1 2024 (setq *hemlock-document-controller* (call-next-method)) 2025 (setf (slot-value *hemlock-document-controller* 'last-encoding) 0)))) 2026 2027 ;;; Return a list of :<NSS>tring<E>ncodings, sorted by the 2028 ;;; (localized) name of each encoding. 2029 (defun supported-nsstring-encodings () 2030 (collect ((ids)) 2031 (let* ((ns-ids (#/availableStringEncodings ns:ns-string))) 2032 (unless (%null-ptr-p ns-ids) 2033 (do* ((i 0 (1+ i))) 2034 () 2035 (let* ((id (paref ns-ids (:* :<NSS>tring<E>ncoding) i))) 2036 (if (zerop id) 2037 (return (sort (ids) 2038 #'(lambda (x y) 2039 (= #$NSOrderedAscending 2040 (#/localizedCompare: 2041 (#/localizedNameOfStringEncoding: ns:ns-string x) 2042 (#/localizedNameOfStringEncoding: ns:ns-string y)))))) 2043 (ids id)))))))) 2044 2045 ;;; TexEdit.app has support for allowing the encoding list in this 2046 ;;; popup to be customized (e.g., to suppress encodings that the 2047 ;;; user isn't interested in.) 2048 (defmethod build-encodings-popup ((self hemlock-document-controller) 2049 &optional (preferred-encoding 0)) 2050 (let* ((id-list (supported-nsstring-encodings)) 2051 (popup (make-instance 'ns:ns-pop-up-button))) 2052 ;;; Add a fake "Automatic" item with tag 0. 2053 (#/addItemWithTitle: popup #@"Automatic") 2054 (#/setTag: (#/itemAtIndex: popup 0) 0) 2055 (dolist (id id-list) 2056 (#/addItemWithTitle: popup (#/localizedNameOfStringEncoding: ns:ns-string id)) 2057 (#/setTag: (#/lastItem popup) id)) 2058 (when preferred-encoding 2059 (#/selectItemWithTag: popup preferred-encoding)) 2060 (#/sizeToFit popup) 2061 popup)) 2062 2063 2064 (objc:defmethod (#/runModalOpenPanel:forTypes: :<NSI>nteger) 2065 ((self hemlock-document-controller) panel types) 2066 (let* ((popup (build-encodings-popup self #|preferred|#))) 2067 (#/setAccessoryView: panel popup) 2068 (let* ((result (call-next-method panel types))) 2069 (when (= result #$NSOKButton) 2070 (with-slots (last-encoding) self 2071 (setq last-encoding (#/tag (#/selectedItem popup))))) 2072 result))) 2073 1983 2074 (defun hi::open-document () 1984 2075 (#/performSelectorOnMainThread:withObject:waitUntilDone: 1985 (#/sharedDocumentController ns:ns-document-controller)2076 (#/sharedDocumentController hemlock-document-controller) 1986 2077 (@selector #/openDocument:) +null-ptr+ t)) 1987 2078 … … 1994 2085 (#/performSelectorOnMainThread:withObject:waitUntilDone: 1995 2086 self (@selector #/saveDocumentAs:) +null-ptr+ t)) 2087 2088 (defun initialize-user-interface () 2089 (#/sharedDocumentController hemlock-document-controller) 2090 (#/sharedPanel preferences-panel) 2091 (update-cocoa-defaults) 2092 (make-editor-style-map)) 1996 2093 1997 2094 ;;; This needs to run on the main thread.
Note:
See TracChangeset
for help on using the changeset viewer.
