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

Contents of /src/hemlock/group.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: +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/group.lisp,v 1.3 1994/10/31 04:50:12 ram Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; File group stuff for Hemlock.
13 ;;; Written by Skef Wholey and Rob MacLachlan.
14 ;;;
15 ;;; The "Compile Group" and "List Compile Group" commands in lispeval
16 ;;; also know about groups.
17 ;;;
18 ;;; This file provides Hemlock commands for manipulating groups of files
19 ;;; that make up a larger system. A file group is a set of files whose
20 ;;; names are listed in some other file. At any given time one group of
21 ;;; files is the Active group. The Select Group command makes a group the
22 ;;; Active group, prompting for the name of a definition file if the group
23 ;;; has not been selected before. Once a group has been selected once, the
24 ;;; name of the definition file associated with that group is retained. If
25 ;;; one wishes to change the name of the definition file after a group has
26 ;;; been selected, one should call Select Group with a prefix argument.
27
28 (in-package "HEMLOCK")
29
30 (defvar *file-groups* (make-string-table)
31 "A string table of file groups.")
32
33 (defvar *active-file-group* ()
34 "The list of files in the currently active group.")
35
36 (defvar *active-file-group-name* ()
37 "The name of the currently active group.")
38
39
40
41 ;;;; Selecting the active group.
42
43 (defcommand "Select Group" (p)
44 "Makes a group the active group. With a prefix argument, changes the
45 definition file associated with the group."
46 "Makes a group the active group."
47 (let* ((group-name
48 (prompt-for-keyword
49 (list *file-groups*)
50 :must-exist nil
51 :prompt "Select Group: "
52 :help
53 "Type the name of the file group you wish to become the active group."))
54 (old (getstring group-name *file-groups*))
55 (pathname
56 (if (and old (not p))
57 old
58 (prompt-for-file :must-exist t
59 :prompt "From File: "
60 :default (merge-pathnames
61 (make-pathname
62 :name group-name
63 :type "upd")
64 (value pathname-defaults))))))
65 (setq *active-file-group-name* group-name)
66 (setq *active-file-group* (nreverse (read-file-group pathname nil)))
67 (setf (getstring group-name *file-groups*) pathname)))
68
69
70 ;;; READ-FILE-GROUP reads an Update format file and returns a list of pathnames
71 ;;; of the files named in that file. This guy knows about @@ indirection and
72 ;;; ignores empty lines and lines that begin with @ but not @@. A simpler
73 ;;; scheme could be used for non-Spice implementations, but all this hair is
74 ;;; probably useful, so Update format may as well be a standard for this sort
75 ;;; of thing.
76 ;;;
77 (defun read-file-group (pathname tail)
78 (with-open-file (file pathname)
79 (do* ((name (read-line file nil nil) (read-line file nil nil))
80 (length (if name (length name)) (if name (length name))))
81 ((null name) tail)
82 (declare (type (or simple-string null) name))
83 (cond ((zerop length))
84 ((char= (char name 0) #\@)
85 (when (and (> length 1) (char= (char name 1) #\@))
86 (setq tail (read-file-group
87 (merge-pathnames (subseq name 2)
88 pathname)
89 tail))))
90 (t
91 (push (merge-pathnames (pathname name) pathname) tail))))))
92
93
94
95 ;;;; DO-ACTIVE-GROUP.
96
97 (defhvar "Group Find File"
98 "If true, group commands use \"Find File\" to read files, otherwise
99 non-resident files are read into the \"Group Search\" buffer."
100 :value nil)
101
102 (defhvar "Group Save File Confirm"
103 "If true, then the group commands will ask for confirmation before saving
104 a modified file." :value t)
105
106 (defmacro do-active-group (&rest forms)
107 "This iterates over the active file group executing forms once for each
108 file. When forms are executed, the file will be in the current buffer,
109 and the point will be at the start of the file."
110 (let ((n-buf (gensym))
111 (n-start-buf (gensym))
112 (n-save (gensym)))
113 `(progn
114 (unless *active-file-group*
115 (editor-error "There is no active file group."))
116
117 (let ((,n-start-buf (current-buffer))
118 (,n-buf nil))
119 (unwind-protect
120 (dolist (file *active-file-group*)
121 (catch 'file-not-found
122 (setq ,n-buf (group-read-file file ,n-buf))
123 (with-mark ((,n-save (current-point) :right-inserting))
124 (unwind-protect
125 (progn
126 (buffer-start (current-point))
127 ,@forms)
128 (move-mark (current-point) ,n-save)))
129 (group-save-file)))
130 (if (member ,n-start-buf *buffer-list*)
131 (setf (current-buffer) ,n-start-buf
132 (window-buffer (current-window)) ,n-start-buf)
133 (editor-error "Original buffer deleted!")))))))
134
135 ;;; GROUP-READ-FILE reads in files for the group commands via DO-ACTIVE-GROUP.
136 ;;; We use FIND-FILE-BUFFER, which creates a new buffer when the file hasn't
137 ;;; already been read, to get files in, and then we delete the buffer if it is
138 ;;; newly created and "Group Find File" is false. This lets FIND-FILE-BUFFER
139 ;;; do all the work. We don't actually use the "Find File" command, so the
140 ;;; buffer history isn't affected.
141 ;;;
142 ;;; Search-Buffer is any temporary search buffer left over from the last file
143 ;;; that we want deleted. We don't do the deletion if the buffer is modified.
144 ;;;
145 (defun group-read-file (name search-buffer)
146 (unless (probe-file name)
147 (message "File ~A not found." name)
148 (throw 'file-not-found nil))
149 (multiple-value-bind (buffer created-p)
150 (find-file-buffer name)
151 (setf (current-buffer) buffer)
152 (setf (window-buffer (current-window)) buffer)
153
154 (when (and search-buffer (not (buffer-modified search-buffer)))
155 (dolist (w (buffer-windows search-buffer))
156 (setf (window-buffer w) (current-buffer)))
157 (delete-buffer search-buffer))
158
159 (if (and created-p (not (value group-find-file)))
160 (current-buffer) nil)))
161
162 ;;; GROUP-SAVE-FILE is used by DO-ACTIVE-GROUP.
163 ;;;
164 (defun group-save-file ()
165 (let* ((buffer (current-buffer))
166 (pn (buffer-pathname buffer))
167 (name (namestring pn)))
168 (when (and (buffer-modified buffer)
169 (or (not (value group-save-file-confirm))
170 (prompt-for-y-or-n
171 :prompt (list "Save changes in ~A? " name)
172 :default t)))
173 (save-file-command ()))))
174
175
176
177 ;;;; Searching and Replacing commands.
178
179 (defcommand "Group Search" (p)
180 "Searches the active group for a specified string, which is prompted for."
181 "Searches the active group for a specified string."
182 (declare (ignore p))
183 (let ((string (prompt-for-string :prompt "Group Search: "
184 :help "String to search for in active file group"
185 :default *last-search-string*)))
186 (get-search-pattern string :forward)
187 (do-active-group
188 (do ((won (find-pattern (current-point) *last-search-pattern*)
189 (find-pattern (current-point) *last-search-pattern*)))
190 ((not won))
191 (character-offset (current-point) won)
192 (command-case
193 (:prompt "Group Search: "
194 :help "Type a character indicating the action to perform."
195 :change-window nil)
196 (:no "Search for the next occurrence.")
197 (:do-all "Go on to the next file in the group."
198 (return nil))
199 ((:exit :yes) "Exit the search."
200 (return-from group-search-command))
201 (:recursive-edit "Enter a recursive edit."
202 (do-recursive-edit)
203 (get-search-pattern string :forward)))))
204 (message "All files in group ~S searched." *active-file-group-name*)))
205
206 (defcommand "Group Replace" (p)
207 "Replaces one string with another in the active file group."
208 "Replaces one string with another in the active file group."
209 (declare (ignore p))
210 (let* ((target (prompt-for-string :prompt "Group Replace: "
211 :help "Target string"
212 :default *last-search-string*))
213 (replacement (prompt-for-string :prompt "With: "
214 :help "Replacement string")))
215 (do-active-group
216 (query-replace-function nil target replacement
217 "Group Replace on previous file" t))
218 (message "Replacement done in all files in group ~S."
219 *active-file-group-name*)))
220
221 (defcommand "Group Query Replace" (p)
222 "Query Replace for the active file group."
223 "Query Replace for the active file group."
224 (declare (ignore p))
225 (let ((target (prompt-for-string :prompt "Group Query Replace: "
226 :help "Target string"
227 :default *last-search-string*)))
228 (let ((replacement (prompt-for-string :prompt "With: "
229 :help "Replacement string")))
230 (do-active-group
231 (unless (query-replace-function
232 nil target replacement "Group Query Replace on previous file")
233 (return nil)))
234 (message "Replacement done in all files in group ~S."
235 *active-file-group-name*))))

  ViewVC Help
Powered by ViewVC 1.1.5