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

Contents of /src/hemlock/icom.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (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.3: +1 -3 lines
Fix headed boilerplate.
1 ram 1.1 ;;; -*- Package: hemlock; Log: hemlock.log -*-
2     ;;;
3 ram 1.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 ram 1.4 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/icom.lisp,v 1.4 1994/10/31 04:50:12 ram Rel $")
9 ram 1.3 ;;;
10     ;;; **********************************************************************
11     ;;;
12 ram 1.1 ;;; This is an italicized comment.
13    
14     (in-package "HEMLOCK")
15    
16     (defun delete-line-italic-marks (line)
17     (dolist (m (hi::line-marks line))
18     (when (and (hi::fast-font-mark-p m)
19     (eql (hi::font-mark-font m) 1))
20     (delete-font-mark m))))
21    
22     (defun set-comment-font (region font)
23     (do ((line (mark-line (region-start region))
24     (line-next line))
25     (end (line-next (mark-line (region-end region)))))
26     ((eq line end))
27     (delete-line-italic-marks line)
28     (let ((pos (position #\; (the simple-string (line-string line)))))
29     (when pos
30     (font-mark line pos font :left-inserting)))))
31    
32     (defun delete-italic-marks-region (region)
33     (do ((line (mark-line (region-start region))
34     (line-next line))
35     (end (line-next (mark-line (region-end region)))))
36     ((eq line end))
37     (delete-line-italic-marks line)))
38    
39    
40     (defmode "Italic"
41     :setup-function
42     #'(lambda (buffer) (set-comment-font (buffer-region buffer) 1))
43     :cleanup-function
44     #'(lambda (buffer) (delete-italic-marks-region (buffer-region buffer))))
45    
46     (define-file-option "Italicize Comments" (buffer value)
47     (declare (ignore value))
48     (setf (buffer-minor-mode buffer "Italic") t))
49    
50     (defcommand "Italic Comment Mode" (p)
51     "Toggle \"Italic\" mode in the current buffer. When in \"Italic\" mode,
52     semicolon comments are displayed in an italic font."
53     "Toggle \"Italic\" mode in the current buffer."
54     (declare (ignore p))
55     (setf (buffer-minor-mode (current-buffer) "Italic")
56     (not (buffer-minor-mode (current-buffer) "Italic"))))
57    
58    
59     (defcommand "Start Italic Comment" (p)
60     "Italicize the text in this comment."
61     "Italicize the text in this comment."
62     (declare (ignore p))
63     (let* ((point (current-point))
64     (pos (mark-charpos point))
65     (line (mark-line point)))
66     (delete-line-italic-marks line)
67     (insert-character point #\;)
68     (font-mark
69     line
70     (or (position #\; (the simple-string (line-string line))) pos)
71     1
72     :left-inserting)))
73    
74 ram 1.2 (bind-key "Start Italic Comment" #k";" :mode "Italic")

  ViewVC Help
Powered by ViewVC 1.1.5