source: trunk/ccl/hemlock/src/cocoa-hemlock.lisp @ 795

Last change on this file since 795 was 795, checked in by gb, 15 years ago

FONT-REGION stuff.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 5.9 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(defstruct (frame-event-queue (:include ccl::locked-dll-header))
10  (signal (ccl::make-semaphore)))
11
12(defstruct (buffer-operation (:include ccl::dll-node))
13  (thunk nil))
14
15(defstruct (event-queue-node (:include ccl::dll-node)
16                             (:constructor make-event-queue-node (event)))
17  event)
18
19(defun event-queue-insert (q node)
20  (ccl::locked-dll-header-enqueue node q)
21  (ccl::signal-semaphore (frame-event-queue-signal q)))
22
23(defun enqueue-key-event (q event)
24  (event-queue-insert q (make-event-queue-node event)))
25
26(defun dequeue-key-event (q)
27  (unless (listen-editor-input q)
28    (let* ((document (buffer-document (current-buffer))))
29      (when document
30        (document-set-point-position document))))
31  (ccl::wait-on-semaphore (frame-event-queue-signal q))
32  (ccl::locked-dll-header-dequeue q))
33
34
35(defun unget-key-event (event q)
36  (ccl::with-locked-dll-header (q)
37    (ccl::insert-dll-node-after (make-event-queue-node  event) q))
38  (ccl::signal-semaphore (frame-event-queue-signal q)))
39
40(defun timed-wait-for-key-event (q seconds)
41  (let* ((signal (frame-event-queue-signal q)))
42    (when (ccl:timed-wait-on-semaphore signal seconds)
43      (ccl:signal-semaphore signal)
44      t)))
45
46
47
48 
49
50(defun buffer-windows (buffer)
51  (let* ((doc (buffer-document buffer)))
52    (when doc
53      (document-panes doc))))
54
55(defvar *current-window* ())
56
57(defvar *window-list* ())
58(defun current-window ()
59  "Return the current window.  The current window is specially treated by
60  redisplay in several ways, the most important of which is that is does
61  recentering, ensuring that the Buffer-Point of the current window's
62  Window-Buffer is always displayed.  This may be set with Setf."
63  *current-window*)
64
65(defun %set-current-window (new-window)
66  #+not-yet
67  (invoke-hook hemlock::set-window-hook new-window)
68  (activate-hemlock-view new-window)
69  (setq *current-window* new-window))
70
71;;; This is a public variable.
72;;;
73(defvar *last-key-event-typed* ()
74  "This variable contains the last key-event typed by the user and read as
75   input.")
76
77(defvar *input-transcript* ())
78
79(defparameter editor-abort-key-events (list #k"Control-g" #k"Control-G"))
80
81(defmacro abort-key-event-p (key-event)
82  `(member (event-queue-node-event ,key-event) editor-abort-key-events))
83
84
85(defun get-key-event (q &optional ignore-pending-aborts)
86  (do* ((e (dequeue-key-event q) (dequeue-key-event q)))
87       ((typep e 'event-queue-node)
88        (unless ignore-pending-aborts
89          (when (abort-key-event-p e)
90            (beep)
91            (throw 'editor-top-level-catcher nil)))
92        (setq *last-key-event-typed* (event-queue-node-event e)))
93    (if (typep e 'buffer-operation)
94      (funcall (buffer-operation-thunk e)))))
95
96(defun listen-editor-input (q)
97  (ccl::with-locked-dll-header (q)
98    (not (eq (ccl::dll-header-first q) q))))
99
100(defun add-buffer-font-region (buffer region)
101  (when (typep buffer 'buffer)
102    (let* ((header (buffer-font-regions buffer))
103           (node (make-font-region-node region)))
104      (ccl::append-dll-node node  header)
105      (setf (font-region-node region) node)
106      region)))
107
108(defun remove-font-region (region)
109  (ccl::remove-dll-node (font-region-node region)))
110
111(defun previous-font-region (region)
112  (let* ((prev-node (ccl::dll-node-pred (font-region-node region))))
113    (if (typep prev-node 'font-region-node)
114      (font-region-node-region prev-node))))
115
116(defun next-font-region (region)
117  (let* ((next-node (ccl::dll-node-succ (font-region-node region))))
118    (if (typep next-node 'font-region-node)
119      (font-region-node-region next-node))))
120
121;;; Make the specified font region "active", if it's non-nil and not
122;;; already active.   A font region is "active" if it and all of its
123;;; successors have "end" marks that're left-inserting, and all of its
124;;; predecessors have "end" marks that're right-inserting.
125;;; It's assumed that when this is called, no other font region is
126;;; active in the buffer.
127
128(defun activate-buffer-font-region (buffer region)
129  (let* ((current (buffer-active-font-region buffer)))
130    (unless (eq current region)
131      (deactivate-buffer-font-region buffer current)
132      (when region
133        (setf (mark-%kind (region-end region)) :left-inserting
134              (mark-%kind (region-start region)) :right-inserting)
135        (do* ((r (next-font-region region) (next-font-region r)))
136             ((null r)
137              current)
138          (setf (mark-%kind (region-end r)) :left-inserting
139                (mark-%kind (region-start r)) :left-inserting)))
140      (setf (buffer-active-font-region buffer) region)
141      current)))
142
143(defun deactivate-buffer-font-region (buffer region)
144  (when (and region (eq (buffer-active-font-region buffer) region))
145    (do* ((r region (next-font-region r)))
146         ((null r) (setf (buffer-active-font-region buffer) nil))
147      (setf (mark-%kind (region-end r)) :right-inserting
148            (mark-%kind (region-start r)) :right-inserting))))
149
150
151(defmacro with-active-font-region ((buffer region) &body body)
152  (let* ((b (gensym))
153         (old (gensym)))
154    `(let* ((,b ,buffer)
155            (,old (activate-buffer-font-region ,b ,region)))
156      (unwind-protect
157           (progn ,@body)
158        (activate-buffer-font-region ,b ,old)))))
159
160   
161(defun show-buffer-font-regions (buffer)
162  (ccl::do-dll-nodes (node (buffer-font-regions buffer))
163    (let* ((r (font-region-node-region node))
164           (start (region-start r))
165           (end (region-end r)))
166      (format t "~& style ~d ~d [~s]/ ~d [~s] ~a"
167              (font-mark-font start)
168              (ccl::mark-absolute-position start)
169              (mark-%kind start)
170              (ccl::mark-absolute-position end)
171              (mark-%kind end)
172              (eq r (buffer-active-font-region buffer))))))
Note: See TracBrowser for help on using the repository browser.