/[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.5 - (show annotations)
Thu Oct 31 04:06:01 2002 UTC (11 years, 5 months ago) by kaz
Branch: MAIN
CVS Tags: mcvs-1-0-3
Changes since 1.4: +3 -0 lines
* code/mcvs-package.lisp: New file, defines META-CVS package.

* code/purge.lisp: Put all symbols in new package.
* code/restore.lisp: Likewise.
* code/paths.lisp: Likewise.
* code/install.sh: Likewise.
* code/restart.lisp: Likewise.
* code/update.lisp: Likewise.
* code/move.lisp: Likewise.
* code/grab.lisp: Likewise.
* code/unix.lisp: Likewise.
* code/slot-refs.lisp: Likewise.
* code/prop.lisp: Likewise.
* code/multi-hash.lisp: Likewise.
* code/rcs-utils.lisp: Likewise.
* code/branch.lisp: Likewise.
* code/find-bind.lisp: Likewise.
* code/execute.lisp: Likewise.
* code/link.lisp: Likewise.
* code/split.lisp: Likewise.
* code/watch.lisp: Likewise.
* code/clisp-unix.lisp: Likewise.
* code/add.lisp: Likewise.
* code/chatter.lisp: Likewise.
* code/print.lisp: Likewise.
* code/types.lisp: Likewise.
* code/remove.lisp: Likewise.
* code/convert.lisp: Likewise.
* code/error.lisp: Likewise.
* code/options.lisp: Likewise.
* code/dirwalk.lisp: Likewise.
* code/checkout.lisp: Likewise.
* code/generic.lisp: Likewise.
* code/sync.lisp: Likewise.
* code/create.lisp: Likewise.
* code/memoize.lisp: Likewise.
* code/seqfuncs.lisp: Likewise.
* code/cmucl-unix.lisp: Likewise.
* code/remap.lisp: Likewise.

* code/mapping.lisp: Put symbols in new package. Replace use
of CLISP specific substring function with subseq.
* code/filt.lisp: Likewise.

* code/mcvs-main.lisp: Put symbols in new package. The mcvs
function is renamed to main.

* code/install.sh: Generate mcvs script that uses qualified name
of new startup functiont to start the software.
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 (require "mcvs-package")
7 (provide "rcs-utils")
8
9 (in-package "META-CVS")
10
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 (defstruct rcs-delta
34 (version)
35 (date)
36 (author)
37 (state)
38 (branches)
39 (next)
40 (newphrases))
41
42 (defstruct rcs-file
43 (admin)
44 (deltas)
45 (delta-hash))
46
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 (rcs-read-token *terminal-io*))
118
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 (defun rcs-parse-newphrases (stream)
153 (let (token newphrases)
154 (with-slot-refs (lexeme) token
155 (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 (defun rcs-parse-admin (stream)
180 (let ((admin (make-rcs-admin))
181 token)
182 (with-multi-slot-refs ((head branch access-list symbols locks locks-strict
183 comment expand newphrases) admin
184 (lexeme) token)
185 ;; 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 (setf newphrases (rcs-parse-newphrases stream))
258 admin)))
259
260 (defun rcs-parse-delta (stream)
261 (let ((delta (make-rcs-delta))
262 token)
263 (with-multi-slot-refs ((version date author state branches
264 next newphrases) delta
265 (lexeme) token)
266 ;; 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 (loop
297 (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
323 (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 (defun rcs-parse (stream)
331 "Parse RCS file."
332 (let ((token-stream (make-rcs-token-stream :stream stream)))
333 ;; We currently just need the admin and delta sections.
334 (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