/[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.9 - (show annotations)
Fri Nov 24 04:53:50 2006 UTC (7 years, 5 months ago) by kaz
Branch: MAIN
CVS Tags: asdf-import-branch~merged-to-HEAD-0, mcvs-1-1-98, asdf-import-branch~branch-point, HEAD
Branch point for: asdf-import-branch
Changes since 1.8: +1 -1 lines
Stylistic change.

* code/add.lisp: Change in-package calls not to use the all-caps
"META-CVS" string string, but rather the :meta-cvs keyword.
* code/branch.lisp: Likewise.
* code/chatter.lisp: Likewise.
* code/checkout.lisp: Likewise.
* code/clisp-unix.lisp: Likewise.
* code/cmucl-unix.lisp: Likewise.
* code/convert.lisp: Likewise.
* code/create.lisp: Likewise.
* code/dirwalk.lisp: Likewise.
* code/error.lisp: Likewise.
* code/execute.lisp: Likewise.
* code/filt.lisp: Likewise.
* code/find-bind.lisp: Likewise.
* code/generic.lisp: Likewise.
* code/grab.lisp: Likewise.
* code/link.lisp: Likewise.
* code/main.lisp: Likewise.
* code/mapping.lisp: Likewise.
* code/memoize.lisp: Likewise.
* code/move.lisp: Likewise.
* code/multi-hash.lisp: Likewise.
* code/options.lisp: Likewise.
* code/paths.lisp: Likewise.
* code/print.lisp: Likewise.
* code/prop.lisp: Likewise.
* code/purge.lisp: Likewise.
* code/rcs-utils.lisp: Likewise.
* code/remap.lisp: Likewise.
* code/remove.lisp: Likewise.
* code/restart.lisp: Likewise.
* code/restore.lisp: Likewise.
* code/seqfuncs.lisp: Likewise.
* code/slot-refs.lisp: Likewise.
* code/split.lisp: Likewise.
* code/sync.lisp: Likewise.
* code/types.lisp: Likewise.
* code/unix.lisp: Likewise.
* code/update.lisp: Likewise.
* code/watch.lisp: Likewise.
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 (in-package :meta-cvs)
6
7 (defstruct rcs-token
8 (type)
9 (lexeme))
10
11 (defstruct rcs-token-stream
12 (stream)
13 (pushback-stack))
14
15 (defgeneric rcs-read-token (stream))
16 (defgeneric rcs-peek-token (stream tok))
17
18 (defstruct rcs-admin
19 (head)
20 (branch)
21 (access-list)
22 (symbols)
23 (locks)
24 (locks-strict)
25 (comment)
26 (expand)
27 (newphrases))
28
29 (defstruct rcs-delta
30 (version)
31 (date)
32 (author)
33 (state)
34 (branches)
35 (next)
36 (newphrases))
37
38 (defstruct rcs-file
39 (admin)
40 (deltas)
41 (delta-hash))
42
43 (defun rcs-special-p (ch)
44 (or (char= ch #\$) (char= ch #\,) (char= ch #\.)
45 (char= ch #\;) (char= ch #\:) (char= ch #\@)))
46
47 (defun rcs-extract-id-sym-or-num (stream)
48 (let (contains-dot contains-idchar)
49 (let ((lexeme (with-output-to-string (ss)
50 (loop
51 (let ((ch (peek-char nil stream)))
52 (cond
53 ((char= ch #\.)
54 (setf contains-dot t)
55 (write-char ch ss))
56 ((digit-char-p ch)
57 (write-char ch ss))
58 ((or (rcs-special-p ch) (char= ch #\space)
59 (not (graphic-char-p ch)))
60 (return))
61 (t (setf contains-idchar t)
62 (write-char ch ss)))
63 (read-char stream))))))
64 (make-rcs-token :type (cond
65 ((and contains-dot contains-idchar) :id)
66 (contains-idchar :sym)
67 (t :num))
68 :lexeme lexeme))))
69
70 (defun rcs-extract-string (stream)
71 (read-char stream)
72 (make-rcs-token
73 :type :string
74 :lexeme
75 (with-output-to-string (ss)
76 (let ((state :initial))
77 (loop
78 (let ((ch (peek-char nil stream)))
79 (case state
80 ((:initial)
81 (if (char= ch #\@)
82 (setf state :atsign)
83 (write-char ch ss)))
84 (otherwise
85 (if (char= ch #\@)
86 (progn
87 (write-char ch ss)
88 (setf state :initial))
89 (return))))
90 (read-char stream)))))))
91
92 (defmethod rcs-read-token ((stream stream))
93 (handler-bind ((end-of-file #'(lambda (condition)
94 (declare (ignore condition))
95 (return-from rcs-read-token
96 (load-time-value
97 (make-rcs-token :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