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

Last change on this file since 8177 was 7595, checked in by gz, 12 years ago

A bit of cleanup just so I don't have to merge as much later:

Get rid of gap symbol-macros, get rid of hi::*buffer-gap-context*.
Change editor source code to use functions to look up info in
hi::*current-buffer*. Code that wants to do quick-and-dirty editor
stuff out of context needs to bind hi::*current-buffer*. Note that
really you should setf (current-buffer) but currently that's a little
heavy duty.

Don't export *editor-input* (it will go away eventually, for now I
want warnings to see where it's used).

Get rid of some #+clx stuff.

Make m-x grep be case-insensitive by default. See *grep-ignore-case*.

List all the ide source files explicitly (in cocoa.lisp), so I don't
have to follow REQUIRE trails to see what's going on.

A fix in hi::buffer-note-insertion for temporary marks.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 3.4 KB
Line 
1;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
2;;;
3;;; **********************************************************************
4;;; This code 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#+CMU (ext:file-comment
8  "$Header$")
9;;;
10;;; **********************************************************************
11;;;
12;;; Written by Rob MacLachlan
13;;; Modified by Bill Chiles toward Hemlock running under X.
14;;;
15;;;    This file contains various functions that make up the user interface to
16;;; fonts.
17;;;
18
19(in-package :hemlock-internals)
20
21;;; Default-font used to be in the above list, but when I cleaned up the way
22;;; Hemlock compiles, a name conflict occurred because "Default Font" is a
23;;; Hemlock variable.  It is now exported by the export list in rompsite.lisp.
24
25(defvar *default-font-family* (make-font-family))
26
27
28
29;;;; Creating, Deleting, and Moving.
30
31(defun new-font-region (buffer start-mark end-mark  font)
32  (let* ((start-line (mark-line start-mark))
33         (end-line (mark-line end-mark))
34         (font-start (internal-make-font-mark start-line
35                                              (mark-charpos start-mark)
36                                              :right-inserting
37                                              font))
38         (font-end (internal-make-font-mark end-line
39                                              (mark-charpos end-mark)
40                                              :right-inserting
41                                              font))
42         (region (internal-make-font-region font-start font-end)))
43    (setf (font-mark-region font-start) region
44          (font-mark-region font-end) region)
45    (push font-start (line-marks start-line))
46    (push font-end (line-marks end-line))
47    (add-buffer-font-region buffer region)
48    (buffer-note-font-change buffer region font)
49    region))
50
51
52
53
54
55(defun font-mark (line charpos font &optional (kind :right-inserting))
56  "Returns a font on line at charpos with font.  Font marks must be permanent
57   marks."
58  (unless (or (eq kind :right-inserting) (eq kind :left-inserting))
59    (error "A Font-Mark must be :left-inserting or :right-inserting."))
60  (unless (and (>= font 0) (< font font-map-size))
61    (error "Font number ~S out of range." font))
62  (let ((new (internal-make-font-mark line charpos kind font)))
63    (new-font-mark new line)
64    (push new (line-marks line))
65    (incf (line-font-mark-count line))
66    new))
67
68(defun delete-font-mark (font-mark)
69  "Deletes a font mark."
70  (check-type font-mark font-mark)
71  (let ((line (mark-line font-mark)))
72    (when line
73      (setf (line-marks line) (delq font-mark (line-marks line)))
74      (decf (line-font-mark-count line))
75      (nuke-font-mark font-mark line)
76      (setf (mark-line font-mark) nil))))
77
78(defun delete-line-font-marks (line)
79  "Deletes all font marks on line."
80  (dolist (m (line-marks line))
81    (when (fast-font-mark-p m)
82      (delete-font-mark m))))
83
84(defun move-font-mark (font-mark new-position)
85  "Moves font mark font-mark to location of mark new-position."
86  (check-type font-mark font-mark)
87  (let ((old-line (mark-line font-mark))
88        (new-line (mark-line new-position)))
89    (nuke-font-mark font-mark old-line)
90    (move-mark font-mark new-position)
91    (new-font-mark font-mark new-line)
92    font-mark))
93
94(defun nuke-font-mark (mark line)
95  (new-font-mark mark line))
96
97(defun new-font-mark (mark line)
98  (declare (ignore mark line))
99)
100
Note: See TracBrowser for help on using the repository browser.