source: trunk/source/cocoa-ide/hemlock/src/cocoa-hemlock.lisp @ 8428

Last change on this file since 8428 was 8428, checked in by gz, 11 years ago

Merge of the 'event-ide' branch. Hemlock's thread model has been changed
so that Hemlock commands now run in the Cocoa event thread -- see the
Hemlock file view.lisp for an overview.

IDE compilation has also been reorganized. Hemlock is now more fully
integrated into the IDE and cannot be compiled separately, sorry.

The hemlock-ext package has been repurposed to contain all interfaces
to window-system specific functionality.

There are also many many assorted other changes, cleanups and fixes.

The Hemlock documentation (Hemlock Command Implementor's Manual) in
http://trac.clozure.com/openmcl/wiki now correctly reflects the
implementation, although it doesn't (yet) describe the integration
with Cocoa or the threading model.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 3.3 KB
Line 
1;;; -*- Mode: Lisp; Package: Hemlock-Internals -*-
2;;;
3;;; **********************************************************************
4;;; Hemlock was written as part of the CMU Common Lisp project at
5;;; Carnegie Mellon University, and has been placed in the public domain.
6
7(in-package :hemlock-internals)
8
9(defun add-buffer-font-region (buffer region)
10  (when (typep buffer 'buffer)
11    (let* ((header (buffer-font-regions buffer))
12           (node (make-font-region-node region)))
13      (ccl::append-dll-node node  header)
14      (setf (font-region-node region) node)
15      region)))
16
17(defun remove-font-region (region)
18  (ccl::remove-dll-node (font-region-node region)))
19
20(defun previous-font-region (region)
21  (let* ((prev-node (ccl::dll-node-pred (font-region-node region))))
22    (if (typep prev-node 'font-region-node)
23      (font-region-node-region prev-node))))
24
25(defun next-font-region (region)
26  (let* ((next-node (ccl::dll-node-succ (font-region-node region))))
27    (if (typep next-node 'font-region-node)
28      (font-region-node-region next-node))))
29
30;;; Make the specified font region "active", if it's non-nil and not
31;;; already active.   A font region is "active" if it and all of its
32;;; successors have "end" marks that're left-inserting, and all of its
33;;; predecessors have "end" marks that're right-inserting.
34;;; It's assumed that when this is called, no other font region is
35;;; active in the buffer.
36
37(defun activate-buffer-font-region (buffer region)
38  (let* ((current (buffer-active-font-region buffer)))
39    (unless (eq current region)
40      (deactivate-buffer-font-region buffer current)
41      (when region
42        (setf (mark-%kind (region-end region)) :left-inserting
43              (mark-%kind (region-start region)) :right-inserting)
44        (do* ((r (next-font-region region) (next-font-region r)))
45             ((null r)
46              current)
47          (setf (mark-%kind (region-end r)) :left-inserting
48                (mark-%kind (region-start r)) :left-inserting)))
49      (setf (buffer-active-font-region buffer) region)
50      current)))
51
52(defun deactivate-buffer-font-region (buffer region)
53  (when (and region (eq (buffer-active-font-region buffer) region))
54    (do* ((r region (next-font-region r)))
55         ((null r) (setf (buffer-active-font-region buffer) nil))
56      (setf (mark-%kind (region-end r)) :right-inserting
57            (mark-%kind (region-start r)) :right-inserting))))
58
59
60(defmacro with-active-font-region ((buffer region) &body body)
61  (let* ((b (gensym))
62         (old (gensym)))
63    `(let* ((,b ,buffer)
64            (,old (activate-buffer-font-region ,b ,region)))
65      (unwind-protect
66           (progn ,@body)
67        (activate-buffer-font-region ,b ,old)))))
68
69   
70(defun show-buffer-font-regions (buffer)
71  (ccl::do-dll-nodes (node (buffer-font-regions buffer))
72    (let* ((r (font-region-node-region node))
73           (start (region-start r))
74           (end (region-end r)))
75      (format t "~& style ~d ~d [~s]/ ~d [~s] ~a"
76              (font-mark-font start)
77              (mark-absolute-position start)
78              (mark-%kind start)
79              (mark-absolute-position end)
80              (mark-%kind end)
81              (eq r (buffer-active-font-region buffer))))))
82
83;;; Clipboard
84(defun region-to-clipboard (region)
85  (string-to-clipboard (region-to-string region)))
86
Note: See TracBrowser for help on using the repository browser.