/[meta-cvs]/meta-cvs/F-576B79B06E51052AA09B4F57264D05A9.lisp
ViewVC logotype

Contents of /meta-cvs/F-576B79B06E51052AA09B4F57264D05A9.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4.8.1 - (show annotations)
Wed Apr 23 05:37:35 2003 UTC (11 years ago) by kaz
Branch: mcvs-1-0-branch
CVS Tags: mcvs-1-0-9, mcvs-1-0-8, mcvs-1-0-7
Changes since 1.4: +1 -1 lines
Improved error handling.  Use of tty for user interaction, plus
new global option for selecting non-interactive bail behavior.

* code/mcvs-main.lisp (*global-options*): add --error-bail option.
(*usage*): Describe new option.
(mcvs-execute): Dynamically bind *interactive-error-io* variable
to a stream formed by opening the controlling tty.
Send error message to *error-output* rather than *standard-output*.

* code/unix-bindings/unix.lisp (unix-funcs:ctermid): New function,
FFI interface to mcvs_ctermid.

* code/unix-bindings/wrap.c (mcvs_ctermid): New function.

* code/chatter.lisp (chatter): Chatter now goes to *error-output*
rather than *standard-output*.

* code/error.lisp (*interactive-error-io*): New special variable,
holds stream open to controlling tty.
(mcvs-terminate): New function.
(mcvs-error-handler): Use *interactive-error-io* to print menu
and obtain user input. Support the :bail value of
*mcvs-error-treatment* Plus some cosmetic changes.

* code/options.lisp (filter-mcvs-options): Support --error-bail option.

* code/filt.lisp (mcvs-filt-loop): Bugfix, (read-line t ...)
should be (read-line *standard-input* ...) because t stands
for *terminal-io* rather than *standard-io*, unlike in the
format function!

* code/rcs-utils.lisp (rcs-read-token): Read from *standard-input*
rather than *terminal-io*.
1 ;;; This source file is part of the Meta-CVS program,
2 ;;; which is distributed under the GNU license.
3 ;;; Copyright 2002 Kaz Kylheku
4
5 (require "slot-refs")
6 (provide "rcs-utils")
7
8 (defstruct rcs-token
9 (type)
10 (lexeme))
11
12 (defstruct rcs-token-stream
13 (stream)
14 (pushback-stack))
15
16 (defgeneric rcs-read-token (stream))
17 (defgeneric rcs-peek-token (stream tok))
18
19 (defstruct rcs-admin
20 (head)
21 (branch)
22 (access-list)
23 (symbols)
24 (locks)
25 (locks-strict)
26 (comment)
27 (expand)
28 (newphrases))
29
30 (defstruct rcs-delta
31 (version)
32 (date)
33 (author)
34 (state)
35 (branches)
36 (next)
37 (newphrases))
38
39 (defstruct rcs-file
40 (admin)
41 (deltas)
42 (delta-hash))
43
44 (defun rcs-special-p (ch)
45 (or (char= ch #\$) (char= ch #\,) (char= ch #\.)
46 (char= ch #\;) (char= ch #\:) (char= ch #\@)))
47
48 (defun rcs-extract-id-sym-or-num (stream)
49 (let (contains-dot contains-idchar)
50 (let ((lexeme (with-output-to-string (ss)
51 (loop
52 (let ((ch (peek-char nil stream)))
53 (cond
54 ((char= ch #\.)
55 (setf contains-dot t)
56 (write-char ch ss))
57 ((digit-char-p ch)
58 (write-char ch ss))
59 ((or (rcs-special-p ch) (char= ch #\space)
60 (not (graphic-char-p ch)))
61 (return))
62 (t (setf contains-idchar t)
63 (write-char ch ss)))
64 (read-char stream))))))
65 (make-rcs-token :type (cond
66 ((and contains-dot contains-idchar) :id)
67 (contains-idchar :sym)
68 (t :num))
69 :lexeme lexeme))))
70
71 (defun rcs-extract-string (stream)
72 (read-char stream)
73 (make-rcs-token
74 :type :string
75 :lexeme
76 (with-output-to-string (ss)
77 (let ((state :initial))
78 (loop
79 (let ((ch (peek-char nil stream)))
80 (case state
81 ((:initial)
82 (if (char= ch #\@)
83 (setf state :atsign)
84 (write-char ch ss)))
85 (otherwise
86 (if (char= ch #\@)
87 (progn
88 (write-char ch ss)
89 (setf state :initial))
90 (return))))
91 (read-char stream)))))))
92
93 (defmethod rcs-read-token ((stream stream))
94 (handler-bind ((end-of-file #'(lambda (condition)
95 (declare (ignore condition))
96 (return-from rcs-read-token #s(rcs-token
97 :type :eof
98 :lexeme "")))))
99 (loop
100 (let ((ch (peek-char nil stream)))
101 (cond
102 ((digit-char-p ch)
103 (return (rcs-extract-id-sym-or-num stream)))
104 ((char= ch #\@)
105 (return (rcs-extract-string stream)))
106 ((rcs-special-p ch)
107 (read-char stream)
108 (return (make-rcs-token :type :special :lexeme ch)))
109 ((and (graphic-char-p ch) (not (char= ch #\space)))
110 (return (rcs-extract-id-sym-or-num stream)))
111 (t (read-char stream)))))))
112
113 (defmethod rcs-read-token ((stream t))
114 (rcs-read-token *standard-input*))
115
116 (defmethod rcs-read-token ((rts rcs-token-stream))
117 (with-slots (stream pushback-stack) rts
118 (cond
119 ((pop pushback-stack))
120 (t (rcs-read-token stream)))))
121
122 (defmethod rcs-pushback-token ((rts rcs-token-stream) (tok rcs-token))
123 (push tok (slot-value rts 'pushback-stack)))
124
125 (defun rcs-match-optional (stream type-match &optional lexeme-match)
126 (let ((token (rcs-read-token stream)))
127 (with-slots (type lexeme) token
128 (cond
129 ((and lexeme-match
130 (not (and (eq type type-match) (string= lexeme lexeme-match))))
131 (rcs-pushback-token stream token)
132 nil)
133 ((not (eq type type-match))
134 (rcs-pushback-token stream token)
135 nil)
136 (t token)))))
137
138 (defun rcs-match-token (stream type-match &optional lexeme-match)
139 (let ((token (rcs-read-token stream)))
140 (with-slots (type lexeme) token
141 (if lexeme-match
142 (when (not (and (eq type type-match) (string= lexeme lexeme-match)))
143 (error "rcs-parse: expecting token \"~a\" of type ~a, not \"~a\" of type ~a."
144 lexeme-match type-match lexeme type))
145 (when (not (eq type type-match))
146 (error "rcs-parse: expecting token of type ~a, not ~a." type-match type)))
147 token)))
148
149 (defun rcs-parse-newphrases (stream)
150 (let (token newphrases)
151 (with-slot-refs (lexeme) token
152 (loop
153 (if (setf token (or (rcs-match-optional stream :sym)
154 (rcs-match-optional stream :id)))
155 (let ((phrase (list lexeme)))
156 (loop
157 (cond
158 ((setf token (or (rcs-match-optional stream :sym)
159 (rcs-match-optional stream :id)
160 (rcs-match-optional stream :num)
161 (rcs-match-optional stream :string)))
162 (push lexeme phrase))
163 ((setf token (rcs-match-optional stream :special))
164 (if (char= lexeme #\:)
165 (push lexeme phrase)
166 (progn
167 (rcs-pushback-token stream token)
168 (push (nreverse phrase) newphrases)
169 (return))))
170 (t (push (nreverse phrase) newphrases)
171 (return))))
172 (rcs-match-token stream :special #\;))
173 (return))))
174 (nreverse newphrases)))
175
176 (defun rcs-parse-admin (stream)
177 (let ((admin (make-rcs-admin))
178 token)
179 (with-multi-slot-refs ((head branch access-list symbols locks locks-strict
180 comment expand newphrases) admin
181 (lexeme) token)
182 ;; head { num } ;
183 (rcs-match-token stream :sym "head")
184 (setf token (rcs-match-optional stream :num))
185 (when token
186 (setf head lexeme))
187 (rcs-match-token stream :special #\;)
188
189 ;; { branch { num } ; }
190 (when (rcs-match-optional stream :sym "branch")
191 (setf token (rcs-match-optional stream :num))
192 (when token
193 (setf branch lexeme))
194 (rcs-match-token stream :special #\;))
195
196 ;; access { id } * ;
197 (rcs-match-token stream :sym "access")
198 (loop
199 (setf token (or (rcs-match-optional stream :sym)
200 (rcs-match-optional stream :id)))
201 (if token
202 (push lexeme access-list)
203 (return)))
204 (nreverse access-list)
205 (rcs-match-token stream :special #\;)
206
207 ;; symbols { sym : num }* ;
208 (rcs-match-token stream :sym "symbols")
209 (loop
210 (setf token (rcs-match-optional stream :sym))
211 (cond
212 (token
213 (let ((symbol lexeme))
214 (rcs-match-token stream :special #\:)
215 (setf token (rcs-match-token stream :num))
216 (push (list symbol lexeme) symbols)))
217 (t (return))))
218 (nreverse symbols)
219 (rcs-match-token stream :special #\;)
220
221 ;; locks { id : num }* ; { strict ; }
222 (rcs-match-token stream :sym "locks")
223 (loop
224 (setf token (or (rcs-match-optional stream :sym)
225 (rcs-match-optional stream :id)))
226 (cond
227 (token
228 (let ((symbol lexeme))
229 (rcs-match-token stream :special #\:)
230 (setf token (rcs-match-token stream :num))
231 (push (list symbol lexeme) locks)))
232 (t (return))))
233 (nreverse locks)
234 (rcs-match-token stream :special #\;)
235 (when (rcs-match-optional stream :sym "strict")
236 (setf locks-strict t)
237 (rcs-match-token stream :special #\;))
238
239 ;; { comment { string } ; }
240 (when (rcs-match-optional stream :sym "comment")
241 (setf token (rcs-match-optional stream :string))
242 (when token
243 (setf comment lexeme))
244 (rcs-match-token stream :special #\;))
245
246 ;; { expand { string } ; }
247 (when (rcs-match-optional stream :sym "expand")
248 (setf token (rcs-match-optional stream :string))
249 (when token
250 (setf expand lexeme))
251 (rcs-match-token stream :special #\;))
252
253 ;; { newphrase }*
254 (setf newphrases (rcs-parse-newphrases stream))
255 admin)))
256
257 (defun rcs-parse-delta (stream)
258 (let ((delta (make-rcs-delta))
259 token)
260 (with-multi-slot-refs ((version date author state branches
261 next newphrases) delta
262 (lexeme) token)
263 ;; num
264 (setf token (rcs-match-optional stream :num))
265 (if (not token)
266 (return-from rcs-parse-delta nil))
267
268 (setf version lexeme)
269
270 ;; date num ;
271 (rcs-match-token stream :sym "date")
272 (setf token (rcs-match-token stream :num))
273 (setf date lexeme)
274 (rcs-match-token stream :special #\;)
275
276 ;; author id ;
277 (rcs-match-token stream :sym "author")
278 (setf token (or (rcs-match-optional stream :sym)
279 (rcs-match-token stream :id)))
280 (setf author lexeme)
281 (rcs-match-token stream :special #\;)
282
283 ;; state { id } ;
284 (rcs-match-token stream :sym "state")
285 (setf token (or (rcs-match-optional stream :sym)
286 (rcs-match-optional stream :id)))
287 (when token
288 (setf state lexeme))
289 (rcs-match-token stream :special #\;)
290
291 ;; branches { num } * ;
292 (rcs-match-token stream :sym "branches")
293 (loop
294 (let ((token (rcs-match-optional stream :num)))
295 (if token
296 (push lexeme branches)
297 (return (nreverse branches)))))
298 (rcs-match-token stream :special #\;)
299
300 ;; next { num } ;
301 (rcs-match-token stream :sym "next")
302 (setf token (rcs-match-optional stream :num))
303 (when token
304 (setf next lexeme))
305 (rcs-match-token stream :special #\;)
306
307 ;; { newphrase }*
308 (when (not (rcs-match-optional stream :sym "desc"))
309 (setf newphrases (rcs-parse-newphrases stream)))
310 delta)))
311
312 (defun rcs-parse-deltas (stream)
313 (let (deltas)
314 (loop
315 (let ((delta (rcs-parse-delta stream)))
316 (if delta
317 (push delta deltas)
318 (return (nreverse deltas)))))))
319
320 (defun rcs-make-delta-hash (deltas)
321 (let ((hash (make-hash-table :test #'equal)))
322 (mapc #'(lambda (delta)
323 (setf (gethash (slot-value delta 'next) hash) delta))
324 deltas)
325 hash))
326
327 (defun rcs-parse (stream)
328 "Parse RCS file."
329 (let ((token-stream (make-rcs-token-stream :stream stream)))
330 ;; We currently just need the admin and delta sections.
331 (let ((file (make-rcs-file :admin (rcs-parse-admin token-stream)
332 :deltas (rcs-parse-deltas token-stream))))
333 (setf (slot-value file 'delta-hash)
334 (rcs-make-delta-hash (slot-value file 'deltas)))
335 file)))

  ViewVC Help
Powered by ViewVC 1.1.5