/[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.6 - (hide annotations)
Wed Apr 23 05:39:27 2003 UTC (10 years, 11 months ago) by kaz
Branch: MAIN
Changes since 1.5: +1 -1 lines
Merging from mcvs-1-0-branch.

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

  ViewVC Help
Powered by ViewVC 1.1.5