/[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.3 - (hide annotations)
Wed Mar 20 18:26:42 2002 UTC (12 years, 1 month ago) by kaz
Branch: MAIN
Changes since 1.2: +8 -19 lines
Some new macros for slot access.

* slot-refs.lisp: New file.
(with-slot-refs): New macro.
(with-multi-slot-refs): New macro.

* rcsparse.lisp (rcs-parse-newphrases, rcs-parse-admin,
rcs-parse-delta): Replace uses
of symbol-macrolet by with-slot-refs and with-multi-slot-refs.
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.1 (provide "rcsparse")
7    
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     (deltas))
42 kaz 1.1
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 #s(rcs-token
96     :type :eof
97     :lexeme "")))))
98     (loop
99     (let ((ch (peek-char nil stream)))
100     (cond
101     ((digit-char-p ch)
102     (return (rcs-extract-id-sym-or-num stream)))
103     ((char= ch #\@)
104     (return (rcs-extract-string stream)))
105     ((rcs-special-p ch)
106     (read-char stream)
107     (return (make-rcs-token :type :special :lexeme ch)))
108     ((and (graphic-char-p ch) (not (char= ch #\space)))
109     (return (rcs-extract-id-sym-or-num stream)))
110     (t (read-char stream)))))))
111    
112     (defmethod rcs-read-token ((stream t))
113     (rcs-read-token *terminal-io*))
114    
115     (defmethod rcs-read-token ((rts rcs-token-stream))
116     (with-slots (stream pushback-stack) rts
117     (cond
118     ((pop pushback-stack))
119     (t (rcs-read-token stream)))))
120    
121     (defmethod rcs-pushback-token ((rts rcs-token-stream) (tok rcs-token))
122     (push tok (slot-value rts 'pushback-stack)))
123    
124     (defun rcs-match-optional (stream type-match &optional lexeme-match)
125     (let ((token (rcs-read-token stream)))
126     (with-slots (type lexeme) token
127     (cond
128     ((and lexeme-match
129     (not (and (eq type type-match) (string= lexeme lexeme-match))))
130     (rcs-pushback-token stream token)
131     nil)
132     ((not (eq type type-match))
133     (rcs-pushback-token stream token)
134     nil)
135     (t token)))))
136    
137     (defun rcs-match-token (stream type-match &optional lexeme-match)
138     (let ((token (rcs-read-token stream)))
139     (with-slots (type lexeme) token
140     (if lexeme-match
141     (when (not (and (eq type type-match) (string= lexeme lexeme-match)))
142     (error "rcs-parse: expecting token \"~a\" of type ~a, not \"~a\" of type ~a."
143     lexeme-match type-match lexeme type))
144     (when (not (eq type type-match))
145     (error "rcs-parse: expecting token of type ~a, not ~a." type-match type)))
146     token)))
147    
148 kaz 1.2 (defun rcs-parse-newphrases (stream)
149     (let (token newphrases)
150 kaz 1.3 (with-slot-refs (lexeme) token
151 kaz 1.2 (loop
152     (if (setf token (or (rcs-match-optional stream :sym)
153     (rcs-match-optional stream :id)))
154     (let ((phrase (list lexeme)))
155     (loop
156     (cond
157     ((setf token (or (rcs-match-optional stream :sym)
158     (rcs-match-optional stream :id)
159     (rcs-match-optional stream :num)
160     (rcs-match-optional stream :string)))
161     (push lexeme phrase))
162     ((setf token (rcs-match-optional stream :special))
163     (if (char= lexeme #\:)
164     (push lexeme phrase)
165     (progn
166     (rcs-pushback-token stream token)
167     (push (nreverse phrase) newphrases)
168     (return))))
169     (t (push (nreverse phrase) newphrases)
170     (return))))
171     (rcs-match-token stream :special #\;))
172     (return))))
173     (nreverse newphrases)))
174    
175 kaz 1.1 (defun rcs-parse-admin (stream)
176     (let ((admin (make-rcs-admin))
177     token)
178 kaz 1.3 (with-multi-slot-refs ((head branch access-list symbols locks locks-strict
179     comment expand newphrases) admin
180     (lexeme) token)
181 kaz 1.1 ;; head { num } ;
182     (rcs-match-token stream :sym "head")
183     (setf token (rcs-match-optional stream :num))
184     (when token
185     (setf head lexeme))
186     (rcs-match-token stream :special #\;)
187    
188     ;; { branch { num } ; }
189     (when (rcs-match-optional stream :sym "branch")
190     (setf token (rcs-match-optional stream :num))
191     (when token
192     (setf branch lexeme))
193     (rcs-match-token stream :special #\;))
194    
195     ;; access { id } * ;
196     (rcs-match-token stream :sym "access")
197     (loop
198     (setf token (or (rcs-match-optional stream :sym)
199     (rcs-match-optional stream :id)))
200     (if token
201     (push lexeme access-list)
202     (return)))
203     (nreverse access-list)
204     (rcs-match-token stream :special #\;)
205    
206     ;; symbols { sym : num }* ;
207     (rcs-match-token stream :sym "symbols")
208     (loop
209     (setf token (rcs-match-optional stream :sym))
210     (cond
211     (token
212     (let ((symbol lexeme))
213     (rcs-match-token stream :special #\:)
214     (setf token (rcs-match-token stream :num))
215     (push (list symbol lexeme) symbols)))
216     (t (return))))
217     (nreverse symbols)
218     (rcs-match-token stream :special #\;)
219    
220     ;; locks { id : num }* ; { strict ; }
221     (rcs-match-token stream :sym "locks")
222     (loop
223     (setf token (or (rcs-match-optional stream :sym)
224     (rcs-match-optional stream :id)))
225     (cond
226     (token
227     (let ((symbol lexeme))
228     (rcs-match-token stream :special #\:)
229     (setf token (rcs-match-token stream :num))
230     (push (list symbol lexeme) locks)))
231     (t (return))))
232     (nreverse locks)
233     (rcs-match-token stream :special #\;)
234     (when (rcs-match-optional stream :sym "strict")
235     (setf locks-strict t)
236     (rcs-match-token stream :special #\;))
237    
238     ;; { comment { string } ; }
239     (when (rcs-match-optional stream :sym "comment")
240     (setf token (rcs-match-optional stream :string))
241     (when token
242     (setf comment lexeme))
243     (rcs-match-token stream :special #\;))
244    
245     ;; { expand { string } ; }
246     (when (rcs-match-optional stream :sym "expand")
247     (setf token (rcs-match-optional stream :string))
248     (when token
249     (setf expand lexeme))
250     (rcs-match-token stream :special #\;))
251    
252     ;; { newphrase }*
253 kaz 1.2 (setf newphrases (rcs-parse-newphrases stream))
254     admin)))
255    
256     (defun rcs-parse-delta (stream)
257     (let ((delta (make-rcs-delta))
258     token)
259 kaz 1.3 (with-multi-slot-refs ((version date author state branches
260     next newphrases) delta
261     (lexeme) token)
262 kaz 1.2 ;; num
263     (setf token (rcs-match-optional stream :num))
264     (if (not token)
265     (return-from rcs-parse-delta nil))
266    
267     (setf version lexeme)
268    
269     ;; date num ;
270     (rcs-match-token stream :sym "date")
271     (setf token (rcs-match-token stream :num))
272     (setf date lexeme)
273     (rcs-match-token stream :special #\;)
274    
275     ;; author id ;
276     (rcs-match-token stream :sym "author")
277     (setf token (or (rcs-match-optional stream :sym)
278     (rcs-match-token stream :id)))
279     (setf author lexeme)
280     (rcs-match-token stream :special #\;)
281    
282     ;; state { id } ;
283     (rcs-match-token stream :sym "state")
284     (setf token (or (rcs-match-optional stream :sym)
285     (rcs-match-optional stream :id)))
286     (when token
287     (setf state lexeme))
288     (rcs-match-token stream :special #\;)
289    
290     ;; branches { num } * ;
291     (rcs-match-token stream :sym "branches")
292 kaz 1.1 (loop
293 kaz 1.2 (let ((token (rcs-match-optional stream :num)))
294     (if token
295     (push lexeme branches)
296     (return (nreverse branches)))))
297     (rcs-match-token stream :special #\;)
298    
299     ;; next { num } ;
300     (rcs-match-token stream :sym "next")
301     (setf token (rcs-match-optional stream :num))
302     (when token
303     (setf next lexeme))
304     (rcs-match-token stream :special #\;)
305    
306     ;; { newphrase }*
307     (when (not (rcs-match-optional stream :sym "desc"))
308     (setf newphrases (rcs-parse-newphrases stream)))
309     delta)))
310    
311     (defun rcs-parse-deltas (stream)
312     (let (deltas)
313     (loop
314     (let ((delta (rcs-parse-delta stream)))
315     (if delta
316     (push delta deltas)
317     (return (nreverse deltas)))))))
318 kaz 1.1
319     (defun rcs-parse (stream)
320     "Parse RCS file."
321     (let ((token-stream (make-rcs-token-stream :stream stream)))
322 kaz 1.2 ;; We currently just need the admin and delta sections.
323     (make-rcs-file :admin (rcs-parse-admin token-stream)
324     :deltas (rcs-parse-deltas token-stream))))

  ViewVC Help
Powered by ViewVC 1.1.5