/[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 - (hide 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 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     (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