/[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 - (hide annotations)
Wed Mar 20 19:32:26 2002 UTC (12 years, 1 month ago) by kaz
Branch: MAIN
CVS Tags: mcvs-1-0, mcvs-0-24, mcvs-0-20, symlink-branch~branch-point, mcvs-0-22, mcvs-0-23, partial-sandbox-branch~branch-point, mcvs-0-21, old-convert-hacking-branch~branch-point, mcvs-0-95, mcvs-0-99, mcvs-0-98, mcvs-1-0-branch~branch-point, partial-sandbox-branch~merged-to-HEAD-0, mcvs-0-97, mcvs-0-96, mcvs-0-16, mcvs-0-15, mcvs-0-14, mcvs-0-17, mcvs-0-11, mcvs-0-10, mcvs-0-13, mcvs-0-12, mcvs-0-19, mcvs-0-18, symlink-branch~merged-to-HEAD-0, deferred-adds-branch~branch-point, mcvs-1-0-5, mcvs-1-0-4, mcvs-1-0-6, mcvs-1-0-1, mcvs-1-0-2
Branch point for: symlink-branch, mcvs-1-0-branch, partial-sandbox-branch, deferred-adds-branch, old-convert-hacking-branch
Changes since 1.3: +15 -4 lines
* rcsparse.lisp: File renamed to rcs-utils.lisp.
(rcs-delta): New slot, delta-hash.
(rcs-make-delta-hash): New function.
(rcs-parse): Calls rcs-make-delta-hash to set up new slot.

* convert.lisp: require changed to match file rename.
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.4 (provide "rcs-utils")
7 kaz 1.1
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 kaz 1.2 (defstruct rcs-delta
31     (version)
32     (date)
33     (author)
34     (state)
35     (branches)
36     (next)
37     (newphrases))
38    
39 kaz 1.1 (defstruct rcs-file
40 kaz 1.2 (admin)
41 kaz 1.4 (deltas)
42     (delta-hash))
43 kaz 1.1
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 *terminal-io*))
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 kaz 1.2 (defun rcs-parse-newphrases (stream)
150     (let (token newphrases)
151 kaz 1.3 (with-slot-refs (lexeme) token
152 kaz 1.2 (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 kaz 1.1 (defun rcs-parse-admin (stream)
177     (let ((admin (make-rcs-admin))
178     token)
179 kaz 1.3 (with-multi-slot-refs ((head branch access-list symbols locks locks-strict
180     comment expand newphrases) admin
181     (lexeme) token)
182 kaz 1.1 ;; 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 kaz 1.2 (setf newphrases (rcs-parse-newphrases stream))
255     admin)))
256    
257     (defun rcs-parse-delta (stream)
258     (let ((delta (make-rcs-delta))
259     token)
260 kaz 1.3 (with-multi-slot-refs ((version date author state branches
261     next newphrases) delta
262     (lexeme) token)
263 kaz 1.2 ;; 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 kaz 1.1 (loop
294 kaz 1.2 (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 kaz 1.1
320 kaz 1.4 (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 kaz 1.1 (defun rcs-parse (stream)
328     "Parse RCS file."
329     (let ((token-stream (make-rcs-token-stream :stream stream)))
330 kaz 1.2 ;; We currently just need the admin and delta sections.
331 kaz 1.4 (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