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

Last change on this file since 12859 was 12859, checked in by gz, 10 years ago

Make sure that all hemlock functions defined outside of hemlock are in the hemlock-ext package, to make it easier to keep track of them

  • 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  (hemlock-ext:string-to-clipboard (region-to-string region)))
86
Note: See TracBrowser for help on using the repository browser.