/[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.1 - (show annotations)
Mon Mar 18 21:51:42 2002 UTC (12 years, 1 month ago) by kaz
Branch: MAIN
* posix.lisp (parse-posix-namestring): New function. Converts POSIX
path to CL Path object.
* rcsparse.lisp: New file
(rcs-admin, rcs-file, rcs-token, rcs-token-stream): New structs.
(rcs-peek-token, rcs-read-token): New generic functions.
(rcs-extract-id-sym-or-num, rcs-extract-string,
rcs-match-optional, rcs-match-token, rcs-parse, rcs-parse-admin,
rcs-special-p): New functions.

* convert.lisp (classify-tags): Work with association list rather
than raw strings.
(mcvs-convert): Use rcs-parse to extract tags. Fix call to
mapping-generate name. Use parse-posix-namestring when opening
version file. Generate informative chatter.
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 (provide "rcsparse")
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-file
30 (admin))
31
32 (defun rcs-special-p (ch)
33 (or (char= ch #\$) (char= ch #\,) (char= ch #\.)
34 (char= ch #\;) (char= ch #\:) (char= ch #\@)))
35
36 (defun rcs-extract-id-sym-or-num (stream)
37 (let (contains-dot contains-idchar)
38 (let ((lexeme (with-output-to-string (ss)
39 (loop
40 (let ((ch (peek-char nil stream)))
41 (cond
42 ((char= ch #\.)
43 (setf contains-dot t)
44 (write-char ch ss))
45 ((digit-char-p ch)
46 (write-char ch ss))
47 ((or (rcs-special-p ch) (char= ch #\space)
48 (not (graphic-char-p ch)))
49 (return))
50 (t (setf contains-idchar t)
51 (write-char ch ss)))
52 (read-char stream))))))
53 (make-rcs-token :type (cond
54 ((and contains-dot contains-idchar) :id)
55 (contains-idchar :sym)
56 (t :num))
57 :lexeme lexeme))))
58
59 (defun rcs-extract-string (stream)
60 (read-char stream)
61 (make-rcs-token
62 :type :string
63 :lexeme
64 (with-output-to-string (ss)
65 (let ((state :initial))
66 (loop
67 (let ((ch (peek-char nil stream)))
68 (case state
69 ((:initial)
70 (if (char= ch #\@)
71 (setf state :atsign)
72 (write-char ch ss)))
73 (otherwise
74 (if (char= ch #\@)
75 (progn
76 (write-char ch ss)
77 (setf state :initial))
78 (return))))
79 (read-char stream)))))))
80
81 (defmethod rcs-read-token ((stream stream))
82 (handler-bind ((end-of-file #'(lambda (condition)
83 (declare (ignore condition))
84 (return-from rcs-read-token #s(rcs-token
85 :type :eof
86 :lexeme "")))))
87 (loop
88 (let ((ch (peek-char nil stream)))
89 (cond
90 ((digit-char-p ch)
91 (return (rcs-extract-id-sym-or-num stream)))
92 ((char= ch #\@)
93 (return (rcs-extract-string stream)))
94 ((rcs-special-p ch)
95 (read-char stream)
96 (return (make-rcs-token :type :special :lexeme ch)))
97 ((and (graphic-char-p ch) (not (char= ch #\space)))
98 (return (rcs-extract-id-sym-or-num stream)))
99 (t (read-char stream)))))))
100
101 (defmethod rcs-read-token ((stream t))
102 (rcs-read-token *terminal-io*))
103
104 (defmethod rcs-read-token ((rts rcs-token-stream))
105 (with-slots (stream pushback-stack) rts
106 (cond
107 ((pop pushback-stack))
108 (t (rcs-read-token stream)))))
109
110 (defmethod rcs-pushback-token ((rts rcs-token-stream) (tok rcs-token))
111 (push tok (slot-value rts 'pushback-stack)))
112
113 (defun rcs-match-optional (stream type-match &optional lexeme-match)
114 (let ((token (rcs-read-token stream)))
115 (with-slots (type lexeme) token
116 (cond
117 ((and lexeme-match
118 (not (and (eq type type-match) (string= lexeme lexeme-match))))
119 (rcs-pushback-token stream token)
120 nil)
121 ((not (eq type type-match))
122 (rcs-pushback-token stream token)
123 nil)
124 (t token)))))
125
126 (defun rcs-match-token (stream type-match &optional lexeme-match)
127 (let ((token (rcs-read-token stream)))
128 (with-slots (type lexeme) token
129 (if lexeme-match
130 (when (not (and (eq type type-match) (string= lexeme lexeme-match)))
131 (error "rcs-parse: expecting token \"~a\" of type ~a, not \"~a\" of type ~a."
132 lexeme-match type-match lexeme type))
133 (when (not (eq type type-match))
134 (error "rcs-parse: expecting token of type ~a, not ~a." type-match type)))
135 token)))
136
137 (defun rcs-parse-admin (stream)
138 (let ((admin (make-rcs-admin))
139 token)
140 (symbol-macrolet ((head (slot-value admin 'head))
141 (branch (slot-value admin 'branch))
142 (access-list (slot-value admin 'access-list))
143 (symbols (slot-value admin 'symbols))
144 (locks (slot-value admin 'locks))
145 (locks-strict (slot-value admin 'locks-strict))
146 (comment (slot-value admin 'comment))
147 (expand (slot-value admin 'expand))
148 (newphrases (slot-value admin 'newphrases))
149 (lexeme (slot-value token 'lexeme)))
150 ;; head { num } ;
151 (rcs-match-token stream :sym "head")
152 (setf token (rcs-match-optional stream :num))
153 (when token
154 (setf head lexeme))
155 (rcs-match-token stream :special #\;)
156
157 ;; { branch { num } ; }
158 (when (rcs-match-optional stream :sym "branch")
159 (setf token (rcs-match-optional stream :num))
160 (when token
161 (setf branch lexeme))
162 (rcs-match-token stream :special #\;))
163
164 ;; access { id } * ;
165 (rcs-match-token stream :sym "access")
166 (loop
167 (setf token (or (rcs-match-optional stream :sym)
168 (rcs-match-optional stream :id)))
169 (if token
170 (push lexeme access-list)
171 (return)))
172 (nreverse access-list)
173 (rcs-match-token stream :special #\;)
174
175 ;; symbols { sym : num }* ;
176 (rcs-match-token stream :sym "symbols")
177 (loop
178 (setf token (rcs-match-optional stream :sym))
179 (cond
180 (token
181 (let ((symbol lexeme))
182 (rcs-match-token stream :special #\:)
183 (setf token (rcs-match-token stream :num))
184 (push (list symbol lexeme) symbols)))
185 (t (return))))
186 (nreverse symbols)
187 (rcs-match-token stream :special #\;)
188
189 ;; locks { id : num }* ; { strict ; }
190 (rcs-match-token stream :sym "locks")
191 (loop
192 (setf token (or (rcs-match-optional stream :sym)
193 (rcs-match-optional stream :id)))
194 (cond
195 (token
196 (let ((symbol lexeme))
197 (rcs-match-token stream :special #\:)
198 (setf token (rcs-match-token stream :num))
199 (push (list symbol lexeme) locks)))
200 (t (return))))
201 (nreverse locks)
202 (rcs-match-token stream :special #\;)
203 (when (rcs-match-optional stream :sym "strict")
204 (setf locks-strict t)
205 (rcs-match-token stream :special #\;))
206
207 ;; { comment { string } ; }
208 (when (rcs-match-optional stream :sym "comment")
209 (setf token (rcs-match-optional stream :string))
210 (when token
211 (setf comment lexeme))
212 (rcs-match-token stream :special #\;))
213
214 ;; { expand { string } ; }
215 (when (rcs-match-optional stream :sym "expand")
216 (setf token (rcs-match-optional stream :string))
217 (when token
218 (setf expand lexeme))
219 (rcs-match-token stream :special #\;))
220
221 ;; { newphrase }*
222 (loop
223 (if (setf token (or (rcs-match-optional stream :sym)
224 (rcs-match-optional stream :id)))
225 (let ((phrase (list lexeme)))
226 (loop
227 (cond
228 ((setf token (or (rcs-match-optional stream :sym)
229 (rcs-match-optional stream :id)
230 (rcs-match-optional stream :num)
231 (rcs-match-optional stream :string)))
232 (push lexeme phrase))
233 ((setf token (rcs-match-optional stream :special))
234 (if (char= lexeme #\:)
235 (push lexeme phrase)
236 (progn
237 (rcs-pushback-token stream token)
238 (push (nreverse phrase) newphrases)
239 (return))))
240 (t (push (nreverse phrase) newphrases)
241 (return))))
242 (rcs-match-token stream :special #\;))
243 (return)))
244 (nreverse newphrases)
245 admin)))
246
247 (defun rcs-parse (stream)
248 "Parse RCS file."
249 (let ((token-stream (make-rcs-token-stream :stream stream)))
250 ;; For now, we just need the admin section.
251 (make-rcs-file :admin (rcs-parse-admin token-stream))))

  ViewVC Help
Powered by ViewVC 1.1.5