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

Contents of /src/hemlock/font.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (hide 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 ram 1.1 ;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
2     ;;;
3     ;;; **********************************************************************
4 ram 1.2 ;;; 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 ram 1.1 ;;; **********************************************************************
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