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

Contents of /src/hemlock/register.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (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.3: +1 -3 lines
Fix headed boilerplate.
1 ;;; -*- Log: hemlock.log; Package: Hemlock -*-
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/register.lisp,v 1.4 1994/10/31 04:50:12 ram Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Registers for holding text and positions.
13 ;;;
14 ;;; Written by Dave Touretzky.
15 ;;; Modified by Bill Chiles for Hemlock consistency.
16 ;;;
17 (in-package "HEMLOCK")
18
19
20
21 ;;;; Registers implementation.
22
23 ;;; Registers are named by characters. Each register refers to a mark or
24 ;;; a cons of a region and the buffer it came from.
25 ;;;
26 (defvar *registers* (make-hash-table))
27
28 (defun register-count ()
29 (hash-table-count *registers*))
30
31 (defun register-value (reg-name)
32 (gethash reg-name *registers*))
33
34 (defsetf register-value (reg-name) (new-value)
35 (let ((name (gensym))
36 (value (gensym))
37 (old-value (gensym)))
38 `(let* ((,name ,reg-name)
39 (,value ,new-value)
40 (,old-value (gethash ,name *registers*)))
41 (when (and ,old-value (markp ,old-value))
42 (delete-mark ,old-value))
43 (setf (gethash ,name *registers*) ,value))))
44
45 (defun prompt-for-register (&optional (prompt "Register: ") must-exist)
46 (let ((reg-name (prompt-for-key-event :prompt prompt)))
47 (unless (or (not must-exist) (gethash reg-name *registers*))
48 (editor-error "Register ~A is empty." reg-name))
49 reg-name))
50
51
52 (defmacro do-registers ((name value &optional sorted) &rest body)
53 (if sorted
54 (let ((sorted-regs (gensym))
55 (reg (gensym)))
56 `(let ((,sorted-regs nil))
57 (declare (list ,sorted-regs))
58 (maphash #'(lambda (,name ,value)
59 (push (cons ,name ,value) ,sorted-regs))
60 *registers*)
61 (setf ,sorted-regs (sort ,sorted-regs #'char-lessp :key #'car))
62 (dolist (,reg ,sorted-regs)
63 (let ((,name (car ,reg))
64 (,value (cdr ,reg)))
65 ,@body))))
66 `(maphash #'(lambda (,name ,value)
67 ,@body)
68 *registers*)))
69
70
71 ;;; Hook to clean things up if a buffer is deleted while registers point to it.
72 ;;;
73 (defun flush-reg-references-to-deleted-buffer (buffer)
74 (do-registers (name value)
75 (etypecase value
76 (mark (when (eq (line-buffer (mark-line value)) buffer)
77 (free-register name)))
78 (cons (free-register-value value buffer)))))
79 ;;;
80 (add-hook delete-buffer-hook 'flush-reg-references-to-deleted-buffer)
81
82
83 (defun free-register (name)
84 (let ((value (register-value name)))
85 (when value (free-register-value value)))
86 (remhash name *registers*))
87
88 (defun free-register-value (value &optional buffer)
89 (etypecase value
90 (mark
91 (when (or (not buffer) (eq (line-buffer (mark-line value)) buffer))
92 (delete-mark value)))
93 (cons
94 (when (and buffer (eq (cdr value) buffer))
95 (setf (cdr value) nil)))))
96
97
98
99 ;;;; Commands.
100
101 ;;; These commands all stash marks and regions with marks that point into some
102 ;;; buffer, and they assume that the register values have the same property.
103 ;;;
104
105 (defcommand "Save Position" (p)
106 "Saves the current location in a register. Prompts for register name."
107 "Saves the current location in a register. Prompts for register name."
108 (declare (ignore p))
109 (let ((reg-name (prompt-for-register)))
110 (setf (register-value reg-name)
111 (copy-mark (current-point) :left-inserting))))
112
113 (defcommand "Jump to Saved Position" (p)
114 "Moves the point to a location previously saved in a register."
115 "Moves the point to a location previously saved in a register."
116 (declare (ignore p))
117 (let* ((reg-name (prompt-for-register "Jump to Register: " t))
118 (val (register-value reg-name)))
119 (unless (markp val)
120 (editor-error "Register ~A does not hold a location." reg-name))
121 (change-to-buffer (line-buffer (mark-line val)))
122 (move-mark (current-point) val)))
123
124 (defcommand "Kill Register" (p)
125 "Kill a regist er. Prompts for the name."
126 "Kill a register. Prompts for the name."
127 (declare (ignore p))
128 (free-register (prompt-for-register "Register to kill: ")))
129
130 (defcommand "List Registers" (p)
131 "Lists all registers in a pop-up window."
132 "Lists all registers in a pop-up window."
133 (declare (ignore p))
134 (with-pop-up-display (f :height (* 2 (register-count)))
135 (do-registers (name val :sorted)
136 (write-string "Reg " f)
137 (ext:print-pretty-key-event name f)
138 (write-string ": " f)
139 (etypecase val
140 (mark
141 (let* ((line (mark-line val))
142 (buff (line-buffer line))
143 (len (line-length line)))
144 (format f "Line ~S, col ~S in buffer ~A~% ~A~:[~;...~]~%"
145 (count-lines (region (buffer-start-mark buff) val))
146 (mark-column val)
147 (buffer-name buff)
148 (subseq (line-string line) 0 (min 61 len))
149 (> len 60))))
150 (cons
151 (let* ((str (region-to-string (car val)))
152 (nl (position #\newline str :test #'char=))
153 (len (length str))
154 (buff (cdr val)))
155 (declare (simple-string str))
156 (format f "Text~@[ from buffer ~A~]~% ~A~:[~;...~]~%"
157 (if buff (buffer-name buff))
158 (subseq str 0 (if nl (min 61 len nl) (min 61 len)))
159 (> len 60))))))))
160
161 (defcommand "Put Register" (p)
162 "Copies a region into a register. Prompts for register name."
163 "Copies a region into a register. Prompts for register name."
164 (declare (ignore p))
165 (let ((region (current-region)))
166 ;; Bind the region before prompting in case the region isn't active.
167 (setf (register-value (prompt-for-register))
168 (cons (copy-region region) (current-buffer)))))
169
170 (defcommand "Get Register" (p)
171 "Copies a region from a register to the current point."
172 "Copies a region from a register to the current point."
173 (declare (ignore p))
174 (let* ((reg-name (prompt-for-register "Register from which to get text: " t))
175 (val (register-value reg-name)))
176 (unless (and (consp val) (regionp (car val)))
177 (editor-error "Register ~A does not hold a region." reg-name))
178 (let ((point (current-point)))
179 (push-buffer-mark (copy-mark point))
180 (insert-region (current-point) (car val))))
181 (setf (last-command-type) :ephemerally-active))

  ViewVC Help
Powered by ViewVC 1.1.5