/[cmucl]/src/hemlock/font.lisp
ViewVC logotype

Contents of /src/hemlock/font.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (show annotations)
Mon Oct 31 04:50:12 1994 UTC (19 years, 5 months ago) by ram
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, double-double-array-base, post-merge-intl-branch, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, intl-branch-working-2010-02-19-1000, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, RELEASE_18d, sse2-packed-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, snapshot-2003-10, snapshot-2004-10, release-18e-base, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, remove_negative_zero_not_zero, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, GIT-CONVERSION, double-double-init-ppc, release-19c, dynamic-extent-base, unicode-utf16-sync-2008-12, LINKAGE_TABLE, release-19c-base, cross-sol-x86-merged, label-2009-03-16, release-19f-base, PRE_LINKAGE_TABLE, merge-sse2-packed, mod-arith-base, sparc_gencgc_merge, merge-with-19f, snapshot-2004-12, snapshot-2004-11, intl-branch-working-2010-02-11-1000, RELEASE_18a, RELEASE_18b, RELEASE_18c, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, release-18e-pre2, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, cold-pcl-base, RELEASE_20b, snapshot-2008-04, snapshot-2003-11, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, cross-sol-x86-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, sparc_gencgc, snapshot-2007-04, snapshot-2010-12, snapshot-2010-11, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2007-06, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, UNICODE-BASE, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, snapshot-2010-08, release-18e, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, cross-sol-x86-2010-12-20, double-double-init-x86, sse2-checkpoint-2008-10-01, intl-branch-2010-03-18-1300, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, cross-sparc-branch-base, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, release-18e-pre1, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09, HEAD
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, portable-clx-branch, sparc_gencgc_branch, cross-sparc-branch, RELEASE-20B-BRANCH, RELENG_18, unicode-string-buffer-branch, sparc-tramp-assem-branch, dynamic-extent, UNICODE-BRANCH, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, lisp-executable, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, release-18e-branch, cold-pcl, unicode-utf16-branch, cross-sol-x86-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
Changes since 1.2: +0 -2 lines
Fix headed boilerplate.
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 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/font.lisp,v 1.3 1994/10/31 04:50:12 ram Rel $")
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 (export '(font-mark delete-font-mark delete-line-font-marks move-font-mark
22 window-font))
23 ;;; Default-font used to be in the above list, but when I cleaned up the way
24 ;;; Hemlock compiles, a name conflict occurred because "Default Font" is a
25 ;;; Hemlock variable. It is now exported by the export list in rompsite.lisp.
26
27 (defvar *default-font-family* (make-font-family))
28
29
30
31 ;;;; Creating, Deleting, and Moving.
32
33 (defun font-mark (line charpos font &optional (kind :right-inserting))
34 "Returns a font on line at charpos with font. Font marks must be permanent
35 marks."
36 (unless (or (eq kind :right-inserting) (eq kind :left-inserting))
37 (error "A Font-Mark must be :left-inserting or :right-inserting."))
38 (unless (and (>= font 0) (< font font-map-size))
39 (error "Font number ~S out of range." font))
40 (let ((new (internal-make-font-mark line charpos kind font)))
41 (new-font-mark new line)
42 (push new (line-marks line))
43 new))
44
45 (defun delete-font-mark (font-mark)
46 "Deletes a font mark."
47 (check-type font-mark font-mark)
48 (let ((line (mark-line font-mark)))
49 (when line
50 (setf (line-marks line) (delq font-mark (line-marks line)))
51 (nuke-font-mark font-mark line)
52 (setf (mark-line font-mark) nil))))
53
54 (defun delete-line-font-marks (line)
55 "Deletes all font marks on line."
56 (dolist (m (line-marks line))
57 (when (fast-font-mark-p m)
58 (delete-font-mark m))))
59
60 (defun move-font-mark (font-mark new-position)
61 "Moves font mark font-mark to location of mark new-position."
62 (check-type font-mark font-mark)
63 (let ((old-line (mark-line font-mark))
64 (new-line (mark-line new-position)))
65 (nuke-font-mark font-mark old-line)
66 (move-mark font-mark new-position)
67 (new-font-mark font-mark new-line)
68 font-mark))
69
70 (defun nuke-font-mark (mark line)
71 (new-font-mark mark line))
72
73 (defun new-font-mark (mark line)
74 (declare (ignore mark))
75 (let ((buffer (line-%buffer line))
76 (number (line-number line)))
77 (when (bufferp buffer)
78 (dolist (w (buffer-windows buffer))
79 (setf (window-tick w) (1- (buffer-modified-tick buffer)))
80 (let ((first (cdr (window-first-line w))))
81 (unless (or (> (line-number (dis-line-line (car first))) number)
82 (> number
83 (line-number
84 (dis-line-line (car (window-last-line w))))))
85 (do ((dl first (cdr dl)))
86 ((or (null dl)
87 (eq (dis-line-line (car dl)) line))
88 (when dl
89 (setf (dis-line-old-chars (car dl)) :font-change))))))))))
90
91
92
93 ;;;; Referencing and setting font ids.
94
95 (defun window-font (window font)
96 "Returns a font id for window and font."
97 (svref (font-family-map (bitmap-hunk-font-family (window-hunk window))) font))
98
99 (defun %set-window-font (window font font-object)
100 (unless (and (>= font 0) (< font font-map-size))
101 (error "Font number ~S out of range." font))
102 (setf (bitmap-hunk-trashed (window-hunk window)) :font-change)
103 (let ((family (bitmap-hunk-font-family (window-hunk window))))
104 (when (eq family *default-font-family*)
105 (setq family (copy-font-family family))
106 (setf (font-family-map family) (copy-seq (font-family-map family)))
107 (setf (bitmap-hunk-font-family (window-hunk window)) family))
108 (setf (svref (font-family-map family) font) font-object)))
109
110 (defun default-font (font)
111 "Returns the font id for font out of the default font family."
112 (svref (font-family-map *default-font-family*) font))
113
114 (defun %set-default-font (font font-object)
115 (unless (and (>= font 0) (< font font-map-size))
116 (error "Font number ~S out of range." font))
117 (dolist (w *window-list*)
118 (when (eq (bitmap-hunk-font-family (window-hunk w)) *default-font-family*)
119 (setf (bitmap-hunk-trashed (window-hunk w)) :font-change)))
120 (setf (svref (font-family-map *default-font-family*) font) font-object))

  ViewVC Help
Powered by ViewVC 1.1.5