/[cparse]/cparse/cparse.lisp
ViewVC logotype

Contents of /cparse/cparse.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Wed Nov 24 20:23:58 2004 UTC (9 years, 4 months ago) by clynbech
Branch: MAIN
CVS Tags: HEAD
Changes since 1.1: +53 -33 lines
* uffi-alien.lisp: New file.

* system.lisp: Removed.

* ctype.lisp (print-object): moved PCL guard into lambda.
(print-object): Added allegro guard.
(defnumtype): Added escapes to documentation string.
(defnumtype): Case-robustified 'const-name' initial value.
(byte): New defnumtype.
(unsigned-byte): New defnumtype.
(short): Moved upwards
(unsigned-short): Moved upwards.
(unsignedp, min-val, c!-internal): Added ignore declaration.
(type-width): Added fallback method.
(def-c-op): Case-robustified 'internal-op' initial value.

* cparse.system: (*cparse-backend*): New variable.
(toplevel): Added require of :uffi when this is backend.
(toplevel): Guarded hash string test with CMU.
(toplevel): Added ASDF to-be-done guard.
(toplevel): Reorganised MK based defsystem.
(toplevel): Added Allegro defsystem.

* cparse.lisp (*cparse-debug*): Added documentation.
(cparse-object): Wrapped in 'eval-when',
(print-object): Moved PCL guard into lambda and added allegro guard.
(defc): Intern initargs in keyword package.
(defc): Wrapped generated class in 'eval-when'.
(+c-keywords+): Added "__extension__".
(tok): Outcommented :number case in return value.
(frob-prim-type): Case-robustified 'cparse-type' value.
(frob-prim-type): Added 'long-long' and 'unsigned-long-long'.
(array-type): Added 'int-const'.
(cparse-stream): Added escapes in documentation.
(cparse-stmt): Added consumption of '__extension__' keywords.
(parse-decl-type): Added debug-ouput.
(parse-declarator): Outcommented second version of this function.
(parse-sizeof): Added :value keyword.
(*a-pointer*): New parameter.
1 ;;;
2 ;;; Copyright (c) 2001 Timothy Moore
3 ;;; All rights reserved.
4 ;;;
5 ;;; Redistribution and use in source and binary forms, with or without
6 ;;; modification, are permitted provided that the following conditions
7 ;;; are met:
8 ;;; 1. Redistributions of source code must retain the above copyright
9 ;;; notice, this list of conditions and the following disclaimer.
10 ;;; 2. Redistributions in binary form must reproduce the above copyright
11 ;;; notice, this list of conditions and the following disclaimer in the
12 ;;; documentation and/or other materials provided with the distribution.
13 ;;; 3. The name of the author may not be used to endorse or promote products
14 ;;; derived from this software without specific prior written permission.
15 ;;;
16 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
17 ;;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
18 ;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
19 ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
20 ;;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
21 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
22 ;;; OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
23 ;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
24 ;;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
25 ;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
26 ;;; SUCH DAMAGE.
27
28 (in-package "CPARSE")
29
30 (defparameter *cparse-version* "0.2.4")
31
32 (defparameter *end-of-file* (list nil))
33
34 (defparameter *cparse-package* (find-package "CPARSE"))
35
36 (defvar *compiler-implementation* nil)
37
38 (defvar *cparse-debug* nil
39 "Turn on debugging output.
40 If not nil and not t turn on even more debugging output.")
41
42 (defclass lookahead-stream ()
43 ((stream :accessor stream :initarg :stream)
44 (lookahead-tok
45 :documentation "Holds the last token created by consume.
46 Conceptually, the head of a lookahead stack of tokens")
47 (lookahead-tok-stack :initform nil
48 :documentation "A stack of tokens that have been \"unread.\"")
49 (file-name :accessor file-name :initarg :file-name)
50 (line-number :accessor line-number :initarg :line-number :initform 1)
51 (unread-stack :accessor unread-stack
52 :initform (make-array 10
53 :element-type 'character
54 :adjustable t
55 :fill-pointer 0))))
56
57 (defmethod initialize-instance :after ((lstream lookahead-stream)
58 &key &allow-other-keys)
59 (with-slots (stream) lstream
60 (loop for first-char = (peek-char nil stream)
61 while (eql first-char #\#)
62 do (parse-line-comment lstream))))
63
64 ;;; Error reporting using line number information stored in the
65 ;;; lookahead-stream. We define a *current-lstream* special variable,
66 ;;; even though it isn't used by any of the parsing functions! We
67 ;;; probably want to move in that direction.
68
69 (defvar *current-lstream*)
70
71 (define-condition cparse-error (error)
72 ((file-name :reader cparse-error-file-name :initarg :file-name
73 :initform (when (boundp '*current-lstream*)
74 (file-name *current-lstream*)))
75 (line-number :reader cparse-error-line-number :initarg :line-number
76 :initform (when (boundp '*current-lstream*)
77 (line-number *current-lstream*)))
78 (format-string :reader cparse-error-format-string
79 :initarg :format-string
80 :initform "parse error")
81 (format-arguments :reader cparse-error-format-arguments
82 :initarg :format-arguments
83 :initform nil))
84 (:report (lambda (condition stream)
85 (format stream "~A ~D: ~?~%"
86 (cparse-error-file-name condition)
87 (cparse-error-line-number condition)
88 (cparse-error-format-string condition)
89 (cparse-error-format-arguments condition)))))
90
91 (defun cparse-error (format-string &rest format-args)
92 (error 'cparse-error
93 :format-string format-string
94 :format-arguments format-args))
95
96 ;;; Basic read-char/unread-char/peek-char for lstreams which have
97 ;;; unlimited unread ability.
98
99 (defgeneric %read-char (stream &optional eof-errorp eof-value recursive-p))
100
101 (defmethod %read-char ((s lookahead-stream)
102 &optional (eof-errorp t) eof-value recursive-p)
103 (with-slots (stream unread-stack) s
104 (if (eql (fill-pointer unread-stack) 0)
105 (read-char stream eof-errorp eof-value recursive-p)
106 (vector-pop unread-stack))))
107
108 (defgeneric %unread-char (c stream))
109
110 (defmethod %unread-char ((c character) (s lookahead-stream))
111 (vector-push-extend c (unread-stack s))
112 nil)
113
114 (defgeneric %peek-char (peek-type stream
115 &optional eof-errorp eof-value recursive-p))
116
117 (defmethod %peek-char ((peek-type null) (s lookahead-stream)
118 &optional (eof-errorp t) eof-value recursive-p)
119 (with-slots (stream unread-stack) s
120 (if (eql (fill-pointer unread-stack) 0)
121 (peek-char nil stream eof-errorp eof-value recursive-p)
122 (aref unread-stack (1- (fill-pointer unread-stack))))))
123
124 ;;; Implement the peek-char behavior of seeking ahead for a character,
125 ;;; discarding others along the way.
126
127 (defmethod %peek-char ((peek-type character) (s lookahead-stream)
128 &optional (eof-errorp t) eof-value recursive-p)
129 (with-slots (stream unread-stack) s
130 (unless (eql (fill-pointer unread-stack) 0)
131 (let ((pos (position peek-type unread-stack :from-end t)))
132 (cond (pos
133 ;; top of stack?
134 (unless (eql (1+ pos) (fill-pointer unread-stack))
135 (setf (fill-pointer unread-stack) (1+ pos)))
136 (return-from %peek-char peek-type))
137 ;; Not found, drain unread-stack
138 (t (setf (fill-pointer unread-stack) 0)))))
139 (peek-char peek-type stream eof-errorp eof-value recursive-p)))
140
141 ;;; Just like read-line, but deals with the unread stack.
142 ;;; XXX Doesn't deal with eof properly...
143
144 (defgeneric %read-line (stream &optional eof-errorp eof-value recursive-p))
145
146 (defmethod %read-line ((s lookahead-stream)
147 &optional (eof-errorp t) eof-value recursive-p)
148 (with-slots (stream unread-stack) s
149 (let ((newline-pos (position #\Newline unread-stack :from-end t)))
150 (cond (newline-pos
151 (multiple-value-prog1
152 (values (reverse (subseq unread-stack (1+ newline-pos))) nil)
153 (setf (fill-pointer unread-stack) newline-pos)))
154 (t (let ((partial-line nil))
155 (when (> (fill-pointer unread-stack) 0)
156 (setf partial-line (reverse unread-stack)
157 (fill-pointer unread-stack) 0))
158 (multiple-value-bind (line-read newline-missing-p)
159 (read-line stream eof-errorp eof-value recursive-p)
160 (values (concatenate 'string partial-line line-read)
161 newline-missing-p))))))))
162
163 (defgeneric look (stream)
164 (:documentation "Get the most recently read token from LSTREAM,
165 without changing its state (except at initialization)."))
166
167 (defmethod look ((lstream lookahead-stream))
168 (with-slots (lookahead-tok) lstream
169 (if (not (slot-boundp lstream 'lookahead-tok))
170 (setf lookahead-tok (get-token lstream)))
171 lookahead-tok))
172
173 (defgeneric consume (stream)
174 (:documentation "Get a new token from LSTREAM."))
175
176 (defmethod consume ((lstream lookahead-stream))
177 (with-slots (lookahead-tok lookahead-tok-stack) lstream
178 ;; returns lookahead-tok
179 (setf lookahead-tok (if lookahead-tok-stack
180 (pop lookahead-tok-stack)
181 (get-token lstream)))))
182
183 (defgeneric push-back (token stream)
184 (:documentation "Push TOKEN back on STREAM. The old lookahead token
185 is saved to be returned in the future by CONSUME."))
186
187 (defmethod push-back (token (lstream lookahead-stream))
188 (with-slots (lookahead-tok lookahead-tok-stack) lstream
189 (push lookahead-tok lookahead-tok-stack)
190 (setf lookahead-tok token)))
191
192 ;;; Check if the stream is at end-of-file.
193 (defgeneric eof-p (lstream))
194
195 (defmethod eof-p ((lstream lookahead-stream))
196 (let* ((maybe-eof (%peek-char nil lstream nil *end-of-file*)))
197 (eq *end-of-file* maybe-eof)))
198
199 (defun whitespace-p (char)
200 (member char '(#\Space #\Newline #\Tab #\Page)))
201
202 ;;; Fancy parsing of "# 1 "/usr/include/sys/types.h" 1 3" statements
203 ;;; in C files that have been run through the C preprocessor.
204
205 (defun readc (lstream)
206 (let ((the-char (%read-char lstream)))
207 (if (eql the-char #\Newline)
208 (loop for next-char = (%peek-char nil lstream nil nil)
209 while (eql next-char #\#)
210 do (parse-line-comment lstream)
211 finally (when next-char
212 (incf (line-number lstream)))))
213 the-char))
214
215 ;;; XXX Gotta deal with #pragma
216 (defun parse-line-comment (lstream)
217 (with-slots (file-name line-number) lstream
218 ;; Eat Initial #
219 (%read-char lstream)
220 ;; Use the lisp reader to parse line number and file name. Gross, but
221 ;; avoids complications in recursively invoking the cparse tokenizer at
222 ;; this point, besides the fact that cparse doesn't parse strings yet.
223 (let ((comment-line (%read-line lstream))
224 next-pos)
225 (multiple-value-setq (line-number next-pos)
226 (read-from-string comment-line))
227 (setf file-name (read-from-string comment-line t nil :start next-pos)))))
228
229 (defun unreadc (c lstream)
230 (when (characterp c)
231 (if (char= c #\newline)
232 (decf (line-number lstream)))
233 (%unread-char c lstream)))
234
235 ;;; A superclass for all our types. We can hang our own print-object method
236 ;;; off it and stuff.
237
238 (eval-when (load compile eval)
239 (defclass cparse-object ()
240 ()))
241
242 ;;; Obviously there are ways to do this in other CLOSes and MOPs, but I
243 ;;; don't know what they are.
244
245 (defmethod print-object ((obj cparse-object) stream)
246 (let ((slots (mapcan #'(lambda (slot-def)
247 (let ((name
248 #+PCL (pcl:slot-definition-name slot-def)
249 #+allegro (mop:slot-definition-name slot-def)))
250 (if (slot-boundp obj name)
251 (list name (slot-value obj name))
252 nil)))
253 #+PCL (pcl:class-slots (class-of obj))
254 #+allegro (mop:class-slots (class-of obj)))))
255 (print-unreadable-object (obj stream :type t)
256 (format stream "~<~@{~W ~@_~W~^ ~_~}~:>" slots))))
257
258 ;;; C types, as opposed to the parse trees that produce them.
259
260 (defmacro defc (class-name supers slots &rest class-options)
261 (let ((new-slots (mapcar #'(lambda (slot)
262 (multiple-value-bind (name args)
263 (cond ((symbolp slot)
264 (values slot nil))
265 ((listp slot)
266 (values (car slot) (cdr slot)))
267 (t
268 (error "Invalid slot ~S" slot)))
269 `(,name :accessor ,name
270 :initarg ,(intern (string name)
271 :keyword)
272 ,@args)))
273 slots)))
274 `(eval-when (load compile eval)
275 (defclass ,class-name ,supers
276 ,new-slots
277 ,@class-options))))
278
279 ;;; Classes for constant numbers
280
281 (defc integer-object (cparse-object)
282 ((value)
283 (base)
284 (digits)))
285
286 (defc unsigned-object (unsigned integer-object)
287 ())
288
289 (defc float-object (cparse-object)
290 ((value)
291 (size)))
292
293 (defun get-integer-base (lstream base)
294 (loop
295 with result = 0
296 for c = (readc lstream)
297 for digit = (and (characterp c) (digit-char-p c base))
298 until (or (eql c *end-of-file*) (null digit))
299 count t into digits
300 do (progn
301 (if (= result 0)
302 (setq result digit)
303 (setq result (+ (* result base) digit))))
304 finally
305 (unreadc c lstream)
306 (return (values result base digits))))
307
308 (defun get-integer (lstream &optional base)
309 "Returns integer value along with the specified base."
310 (let ((c (readc lstream)))
311 (if (eq c *end-of-file*)
312 *end-of-file*
313 (multiple-value-bind (number base digits)
314 (if (eql c #\0)
315 (let ((next-c (readc lstream)))
316 (cond ((or (eql next-c #\x) (eql next-c #\X))
317 (if (or (null base) (eql base 16))
318 (get-integer-base lstream 16)
319 (cparse-error "Unexpected characters 0~C"
320 next-c)))
321 (base
322 (unreadc next-c lstream)
323 (get-integer-base lstream base))
324 ((digit-char-p next-c 8)
325 (unreadc next-c lstream)
326 (get-integer-base lstream 8))
327 ((or (eq next-c *end-of-file*)
328 (not (digit-char-p next-c 8)))
329 (unreadc next-c lstream)
330 (values 0 10 1))
331 (t (cparse-error
332 "Malformed number"))))
333 (progn
334 (unreadc c lstream)
335 (get-integer-base lstream 10)))
336 (make-instance 'integer-object :value number :base base
337 :digits digits)))))
338
339 ;;; return either a positive integer or float
340 (defun parse-number (lstream)
341 (let* ((maybe-point (readc lstream))
342 (looking-at-float (eql maybe-point #\.))
343 mantissa
344 frac
345 exponent)
346 (if (not looking-at-float)
347 (unreadc maybe-point lstream))
348 (let ((first-num (get-integer lstream (and looking-at-float 10))))
349 (if (or (and (typep first-num 'integer-object)
350 (not (eql (base first-num) 10))))
351 (return-from parse-number (make-int-const-w/type first-num
352 lstream))
353 (if looking-at-float
354 (setq mantissa 0 frac first-num)
355 (setq mantissa first-num)))
356 (setq maybe-point (readc lstream))
357 (if (eql maybe-point #\.)
358 (if looking-at-float
359 (cparse-error "Illegal number syntax")
360 (setq frac (get-integer lstream 10)))
361 (progn
362 (unreadc maybe-point lstream)
363 (unless looking-at-float
364 (return-from parse-number (make-int-const-w/type first-num
365 lstream)))))
366 (let ((maybe-exponent (readc lstream)))
367 (if (or (eql maybe-exponent #\e) (eql maybe-exponent #\E))
368 (let ((sign-char (readc lstream))
369 (sign 1))
370 (cond ((eql sign-char #\-)
371 (setq sign -1))
372 ((eql sign-char #\+))
373 (t (unreadc sign-char lstream)))
374 (let ((exp1 (get-integer lstream 10)))
375 (setq exponent (make-instance 'integer-object
376 :value (* sign (value exp1))
377 :base 10
378 :digits (digits exp1)))))
379 (setq exponent 0)))
380 (let* ((maybe-type (readc lstream))
381 (float-type (case maybe-type
382 ((#\f #\F) '|float|)
383 (t (unreadc maybe-type lstream)
384 '|double|))))
385 (make-float-const mantissa frac exponent float-type)))))
386
387 (defun make-int-const-w/type (int-obj lstream)
388 "Use possible trailing type modifier to construct the appropriate
389 integer constant."
390 (let ((char1 (readc lstream))
391 (char2 nil)
392 (char3 nil))
393 (unless (or (equalp char1 #\u) (equalp char1 #\l))
394 (unreadc char1 lstream)
395 (return-from make-int-const-w/type
396 (make-instance 'int-const :value (value int-obj))))
397 (setq char2 (readc lstream))
398 (if (equalp char2 #\l)
399 (when (equalp char1 #\u)
400 (setq char3 (readc lstream))
401 (unless (equalp char3 #\l)
402 (unreadc char3 lstream)))
403 (unreadc char2 lstream))
404 (make-instance (cond ((equalp char3 #\l)
405 'unsigned-long-long-const)
406 ((equalp char2 #\l)
407 (if (equalp char1 #\u)
408 'unsigned-long-const
409 'long-long-const))
410 ((equalp char1 #\l)
411 'long-const)
412 (t 'unsigned-int-const))
413 :value (value int-obj))))
414
415 (defun make-float-const (mant frac exp float-type)
416 (let* ((proto-float (if (eq float-type '|float|)
417 1.0
418 1d0))
419 (mantissa (if (typep mant 'integer-object)
420 (float (value mant) proto-float)
421 (float mant proto-float)))
422 (fraction (if (typep frac 'integer-object)
423 (float (/ (value frac) (expt 10 (digits frac)))
424 proto-float)
425 (float 0 proto-float)))
426 (exponent (if (typep exp 'integer-object)
427 (value exp)
428 0)))
429 (make-instance (ecase float-type
430 (float
431 'cfloat-const)
432 (double
433 'double-const))
434 :value (* (+ mantissa fraction)
435 (expt (float 10.0 proto-float) exponent)))))
436
437 (defun get-special-char (lstream)
438 (flet ((make-op (&rest chars)
439 (intern (apply #'concatenate
440 'simple-string
441 (mapcar #'(lambda (c) (string c)) chars))
442 *cparse-package*)))
443 ;; Check first for characters that could end the file, to avoid
444 ;; reading eof.
445 (let ((char1 (readc lstream)))
446 (if (member char1 '(#\; #\}))
447 (make-op char1)
448 (let ((char2 (readc lstream)))
449 (cond ((and (or (eql char1 #\>) (eql char1 #\<))
450 (eql char1 char2))
451 (let ((char3 (readc lstream)))
452 (if (eql char3 #\=)
453 (make-op char1 char2 "=")
454 (progn
455 (unreadc char3 lstream)
456 (make-op char1 char2)))))
457 ((or (and (eql char1 #\<)
458 (eql char2 #\=))
459 (and (eql char1 #\>)
460 (eql char2 #\=))
461 (and (eql char1 #\+)
462 (member char2 '(#\+ #\=)))
463 (and (eql char1 #\-)
464 (member char2 '(#\- #\=)))
465 (and (eql char1 #\&)
466 (member char2 '(#\& #\=)))
467 (and (eql char1 #\|)
468 (member char2 '(#\| #\=)))
469 (and (member char1 '(#\* #\/ #\^ #\% #\~ #\= #\!))
470 (eql char2 #\=)))
471 (make-op char1 char2))
472 (t (unreadc char2 lstream)
473 (make-op char1))))))))
474
475 ;;; Intern C keywords in the CPARSE package; everything else is
476 ;;; interned in the current package.
477
478 (defparameter +c-keywords+ (make-hash-table :test #'equal))
479
480 (let ((keywords '("float" "double" "typedef" "extern" "void"
481 "char" "int" "long" "const" "volatile" "signed"
482 "unsigned" "short" "struct" "union" "enum"
483 "__attribute__" "__mode__" "__extension__" ; gcc extension
484 "sizeof")))
485 (loop for keyword in keywords
486 do (setf (gethash keyword +c-keywords+) (intern keyword))))
487
488 ;;; Copy the string so that get-token can keep on reusing its
489 ;;; non-simple string. Potentially cons garbage in the bug case.
490
491 (defun intern-token (str)
492 (let* ((the-str #+hash-fill-bug (copy-seq str) #-hash-fill-bug str)
493 (keyword (gethash the-str +c-keywords+)))
494 (if keyword
495 keyword
496 (intern #+hash-fill-bug the-str #-hash-fill-bug (copy-seq str)))))
497
498 (let ((tok (make-array 32 :element-type 'character
499 :adjustable t :fill-pointer 0)))
500 (defun get-token (lstream)
501 (setf (fill-pointer tok) 0)
502 (loop
503 for c = (readc lstream)
504 with state = :begin
505 do (case state
506 ((:begin)
507 (cond
508 ((whitespace-p c)) ;
509 ((digit-char-p c)
510 (unreadc c lstream)
511 (return (parse-number lstream)))
512 ((or (alpha-char-p c) (eql c #\_))
513 (setf state :id)
514 (vector-push-extend c tok))
515 (t
516 (unreadc c lstream)
517 (return-from get-token (get-special-char lstream)))))
518 ((:id)
519 (cond
520 ((or (alphanumericp c) (eql c #\_))
521 (vector-push-extend c tok))
522 (t (loop-finish)))))
523 finally (return (progn
524 (unreadc c lstream)
525 (case state
526 #+nil ;unreachable anyway according to CMUCL
527 ((:number)
528 (cparse-error
529 "How did we get in :number state?"))
530 ((:id)
531 (intern-token tok))
532 (t (cparse-error
533 "Don't know what to return for state ~S.~%"
534 state))))))))
535
536
537 ;;; Shallow copy of a type
538 (defgeneric %copy-type (type new))
539
540 (defun make-empty-type (type)
541 (make-instance (class-of type)))
542
543 (defun copy-type (type &optional (new (make-empty-type type)))
544 (%copy-type type new))
545
546 (defc c-type (cparse-object)
547 ((qualifiers :initform nil)))
548
549 (defmethod %copy-type ((type c-type) new)
550 (setf (qualifiers new) (qualifiers type))
551 new)
552
553 (macrolet ((frob-prim-type (type)
554 (let ((cparse-type (intern (concatenate 'string
555 (symbol-name 'cparse-)
556 (symbol-name type)))))
557 `(defc ,cparse-type (,type c-type)
558 ()))))
559 (frob-prim-type void)
560 (frob-prim-type char)
561 (frob-prim-type unsigned-char)
562 (frob-prim-type signed-char)
563 (frob-prim-type short)
564 (frob-prim-type unsigned-short)
565 (frob-prim-type int)
566 (frob-prim-type unsigned-int)
567 (frob-prim-type long)
568 (frob-prim-type unsigned-long)
569 (frob-prim-type long-long)
570 (frob-prim-type unsigned-long-long)
571 (frob-prim-type cfloat)
572 (frob-prim-type double))
573
574 (defc pointer-type (c-type)
575 ((to :type c-type)))
576
577 (defmethod %copy-type :after ((type pointer-type) new)
578 (setf (to new) (to type)))
579
580 (defc array-type (c-type)
581 ((of :type c-type)
582 (len :type (or int-const fixnum null))))
583
584 (defmethod %copy-type :after ((type array-type) new)
585 (setf (of new) (of type)
586 (len new) (len type)))
587
588 (defc func-type (c-type)
589 ((return-type :type c-type)
590 (args :initform nil)))
591
592 (defmethod %copy-type :after ((type func-type) new)
593 (setf (return-type new) (return-type type)
594 (args new) (args type)))
595
596
597 ;;; The class for scopes. A scope exists for "outer" or file level.
598 ;;; Structures and unions (and functions, someday) introduce local scope too.
599
600 (defc scope (cparse-object)
601 ((objects :initform (make-hash-table))
602 (struct-tags :initform (make-hash-table))
603 (struct-members :initform (make-hash-table))
604 (outer-scope)))
605
606 (defmethod %copy-type :after ((type scope) new)
607 (setf (objects new) (objects type)
608 (struct-tags new) (struct-tags type)
609 (struct-members new) (struct-members type)
610 (outer-scope new) (outer-scope type)))
611
612 (defvar *current-scope* nil)
613
614 (defun get-scope (type key &optional (scope *current-scope*))
615 (gethash key (slot-value scope type)))
616
617 (defun (setf get-scope) (val type key &optional (scope *current-scope*))
618 (setf (gethash key (slot-value scope type)) val))
619
620 (defun lookup (type key)
621 (loop for scope = *current-scope* then (outer-scope scope)
622 while scope
623 do (multiple-value-bind (val found)
624 (gethash key (slot-value scope type))
625 (when found
626 (return (values val t))))
627 finally (return (values nil nil))))
628
629 ;;; Super class for struct-type and union type, since they're pretty much the
630 ;;; same.
631 (defc compound-type (c-type scope)
632 ((tag :initform nil)
633 (members)
634 (size :initform nil)
635 (alignment :initform nil)))
636
637 (defmethod initialize-instance :after ((type compound-type)
638 &key &allow-other-keys)
639 (with-slots (tag outer-scope) type
640 (when (and tag outer-scope)
641 (setf (get-scope 'struct-tags tag outer-scope) type))))
642
643 (defmethod %copy-type :after ((type compound-type) new)
644 (setf (members new) (members type)
645 (size new) (size type)
646 (alignment new) (alignment type)))
647
648 (defclass struct-type (compound-type)
649 ())
650
651 (defclass union-type (compound-type)
652 ())
653
654 ;;; Enums. enumerators is an assoc list of (identifier . value).
655 (defc enum-type (c-type)
656 ((tag :initform nil)
657 (enumerators :initform nil)))
658
659 (defmethod %copy-type :after ((type enum-type) new)
660 (setf (enumerators new) (enumerators type)))
661
662 ;;; Type under construction i.e., haven't seen enough of it yet.
663 (defc incomplete-type ()
664 ((real-type)))
665
666 ;;; stdargs indicator in function arguments
667 (defc stdarg-type ()
668 ())
669
670 ;;; typedef-type isn't a real kind of type; rather, an identifier with
671 ;;; this type names a type.
672
673 (defc typedef-type (cparse-object)
674 ((defined-type)))
675
676 (defun cparse-stream (stream &key
677 file-name
678 ((:compiler *compiler-implementation*)
679 (make-instance 'impl-32bit))
680 scope
681 (stmt-fun #'(lambda (decls scope lstream)
682 (declare (ignore decls scope lstream))
683 (values))))
684 "Parse STREAM for C language constructs. Arguments are:
685 :file-name - Sets the file name in error messages.
686 :compiler - Binds *compiler-implementation* to an object of class
687 compiler-impl that controls the implementation of C arithmetic.
688 Default is an object of type 'impl-32bit.
689 :scope - A scope object, possibly the result of an earlier run of
690 cparse-stream.
691 :stmt-fun - that is called for every statement with
692 \(parse-tree scope lstream\)."
693 (let* ((lstream (make-instance 'lookahead-stream
694 :stream stream
695 :file-name file-name))
696 (*current-lstream* lstream)
697 (*current-scope* (or scope (make-instance 'scope :outer-scope nil))))
698 (handler-case
699 (let ((file-name-for-debug nil))
700 (loop
701 (funcall stmt-fun (cparse-stmt lstream) *current-scope* lstream)
702 (when *cparse-debug*
703 (unless (eql file-name-for-debug (file-name lstream))
704 (format *error-output* "~A: " (file-name lstream)))
705 (format *error-output* "~S " (line-number lstream)))
706 (handler-case (consume lstream)
707 (end-of-file ()
708 (return-from cparse-stream *current-scope*)))))
709 (end-of-file ()
710 (format t "~A ~A: unexpected end of file~%"
711 (file-name lstream) (line-number lstream))))))
712
713 (defun cparse-stmt (lstream)
714 (when (member (look lstream) '(|__extension__|))
715 (consume lstream))
716 (when (eq (look lstream) '|typedef|)
717 (consume lstream)
718 (return-from cparse-stmt
719 (mapcar #'(lambda (typedef)
720 (let ((name (cadr typedef))
721 (typedef-obj
722 (make-instance 'typedef-type
723 :defined-type (car typedef))))
724 (setf (get-scope 'objects name) typedef-obj)
725 (list typedef-obj name)))
726 (cparse-stmt lstream))))
727 (when (eq (look lstream) '|extern|)
728 (consume lstream))
729 (let ((decl-type (parse-decl-type lstream)))
730 (loop
731 collect (multiple-value-bind (declarator id)
732 (parse-declarator lstream decl-type)
733 (setf (get-scope 'objects id) declarator)
734 (list declarator id))
735 do (case (look lstream)
736 (|,| (consume lstream))
737 (|;|
738 ;; Don't (consume lstream); let the caller do it so it can
739 ;; check for eof in a sane manner.
740 (loop-finish))
741 (t (cparse-error "Unexpected token at end of statement: ~S~%"
742 (look lstream)))))))
743
744
745 ;;; Map an ugly control problem into an ugly data problem :) The tail of each
746 ;;; element list is the type if the length qualifier is (nothing long short)
747 (defparameter +size-alist+ '((|void| void)
748 (|char| char)
749 (|int| int long short)
750 (|float| cfloat)
751 (|double| double long-double)
752 (nil nil long short)))
753
754 ;;; Same deal for signed/unsigned: (nothing signed unsigned)
755 (defparameter +signed-alist+ '((void cparse-void)
756 (char cparse-char cparse-signed-char
757 cparse-unsigned-char)
758 (short cparse-short cparse-short
759 cparse-unsigned-short)
760 (int cparse-int cparse-int cparse-unsigned-int)
761 (long cparse-long cparse-long
762 cparse-unsigned-long)
763 (cfloat cparse-cfloat)
764 (double cparse-double)
765 (long-double cparse-long-double)
766 (nil nil cparse-int cparse-unsigned-int)))
767 (defparameter +prim-types+
768 '(|void| |char| |int| |float| |double|))
769
770 (defparameter prim-qualifiers '(|const| |volatile|))
771
772 (defparameter +length-decls+ '(|short| |long|))
773 (defparameter +sign-decls+ '(|signed| |unsigned|))
774
775 (defun make-prim-type (qualifiers keywords)
776 (let ((len (intersection keywords +length-decls+ :test #'eq))
777 (sign (intersection keywords +sign-decls+ :test #'eq))
778 (ptype (intersection keywords +prim-types+ :test #'eq))
779 (augmented-type nil))
780 (unless (and (<= (length sign) 1) (<= (length ptype) 1))
781 (cparse-error "Illegal declarators: ~S" keywords))
782 (if (and (null ptype) (equal len '(|long| |long|)))
783 (setq augmented-type (if (eq (car sign) '|unsigned|)
784 'cparse-unsigned-long-long
785 'cparse-long-long))
786 (let* ((size-map (cdr (assoc (car ptype) +size-alist+ )))
787 (sized-type (case (car len)
788 ((nil)
789 (car size-map))
790 (|long|
791 (cadr size-map))
792 (|short|
793 (caddr size-map))))
794 (sign-map (cdr (assoc sized-type +signed-alist+))))
795 (setq augmented-type (case (car sign)
796 ((nil)
797 (car sign-map))
798 (|signed|
799 (cadr sign-map))
800 (|unsigned|
801 (caddr sign-map))))
802 #+nil(format t "ptype ~S len ~S size-map ~S sized-type ~S sign-map ~S augmented-type ~S"
803 ptype len size-map sized-type sign-map augmented-type)))
804 (unless augmented-type
805 (cparse-error "Not a legal set of type keywords: ~S" keywords))
806 (make-instance augmented-type :qualifiers qualifiers)))
807
808 ;;; The list of non-qualifier keywords that appear in a declaration
809 ;;; and don't cause any interesting behavior in their own right.
810
811 (defparameter +decl-keywords+ (append +prim-types+ +length-decls+
812 +sign-decls+))
813
814 (defun parse-decl-type (lstream)
815 (let ((maybe-typedef)
816 (typedef-type nil)
817 (qualifiers nil)
818 (keywords nil))
819 ;; add qualifiers, check that no other modifiers were specified.
820 (flet ((do-qualifiers (type)
821 (when keywords
822 (cparse-error
823 "Illegal qualifier with struct, union, or enum"))
824 (if qualifiers
825 (let ((new-type (copy-type type)))
826 (setf (qualifiers new-type) qualifiers)
827 new-type)
828 type)))
829 (loop
830 for token = (look lstream) then (consume lstream)
831 do (when (and *cparse-debug* (not (eq *cparse-debug* t)))
832 (format *error-output* "Next token: ~S~%" token))
833 (cond
834 ((member token +decl-keywords+ :test #'eq)
835 (push token keywords))
836 ;; use value of setq
837 ((setq maybe-typedef (lookup 'objects token))
838 (setq typedef-type (defined-type maybe-typedef)))
839 ((member token prim-qualifiers :test #'eq)
840 (pushnew token qualifiers))
841 ((or (eq token '|struct|) (eq token '|union|))
842 (return-from parse-decl-type
843 (do-qualifiers (parse-struct-union lstream))))
844 ((eq token '|enum|)
845 (return-from parse-decl-type
846 (do-qualifiers (parse-enum lstream))))
847 (t (loop-finish))))
848 (if typedef-type
849 (do-qualifiers typedef-type)
850 (make-prim-type qualifiers keywords)))))
851 #+nil ;why are there two versions of this function --tedchly/20040401
852 (defun parse-declarator (lstream decl-type)
853 (let (new-type
854 id
855 standin-type)
856 (case (look lstream)
857 (*
858 (multiple-value-setq (new-type id) (parse-pointer lstream decl-type)))
859 (|(|
860 (consume lstream)
861 (setq standin-type (make-instance 'c-type))
862 (multiple-value-setq (new-type id)
863 (parse-declarator lstream standin-type))
864 (if (not (eq '|)| (look lstream)))
865 (cparse-error "Expected ) but got ~S~%" (look lstream))
866 (consume lstream)))))
867 (multiple-value-bind (new-type id)
868 (case (look lstream)
869 (*
870 (parse-pointer lstream decl-type))
871 (|(|
872 (consume lstream)
873 (multiple-value-prog1
874 (parse-declarator lstream decl-type)
875 (if (not (eq '|)| (look lstream)))
876 (cparse-error "Expected ) but got ~S~%" (look lstream))
877 (consume lstream))))
878 (t (parse-id lstream decl-type)))
879 (values (case (look lstream)
880 (|[|
881 (parse-array lstream decl-type))
882 (|(|
883 (parse-function lstream decl-type))
884 (t new-type))
885 id)))
886
887 (defun parse-declarator (lstream decl-type)
888 (let ((standin-type nil))
889 (multiple-value-bind (new-type id)
890 (case (look lstream)
891 (*
892 (parse-pointer lstream decl-type))
893 (|(|
894 (consume lstream)
895 (setq standin-type (make-instance 'c-type))
896 (multiple-value-prog1
897 (parse-declarator lstream standin-type)
898 (if (not (eq '|)| (look lstream)))
899 (cparse-error "Expected ) but got ~S~%" (look lstream))
900 (consume lstream))))
901 (t (parse-id lstream decl-type)))
902 (let* ((return-type (if standin-type ;return type of function or array of
903 decl-type
904 new-type))
905 (array-or-function (case (look lstream)
906 (|[|
907 (parse-array lstream return-type))
908 (|(|
909 (parse-function lstream return-type))
910 (t return-type))))
911 (if standin-type
912 (progn
913 (change-class standin-type
914 (#+PCL pcl::class-of #-pcl class-of
915 array-or-function))
916 (copy-type array-or-function standin-type)
917 (values new-type id))
918 (values array-or-function id))))))
919
920
921 (defun parse-pointer (lstream decl-type)
922 (let ((qualifiers nil))
923 (loop
924 for maybe-qualifier = (consume lstream) ;eat initial *
925 while (member maybe-qualifier '(|const| |volatile|))
926 do (pushnew maybe-qualifier qualifiers))
927 (let ((ptype (make-instance 'pointer-type
928 :to decl-type
929 :qualifiers qualifiers)))
930 (parse-declarator lstream ptype))))
931
932 (defun identifierp (id)
933 (and (symbolp id)
934 id
935 (loop
936 with name = (string id)
937 for c across (the simple-string name)
938 for first = t then nil
939 always (or (and first (or (alpha-char-p c) (char= c #\_)))
940 (and (not first) (or (alphanumericp c) (char= c #\_)))))))
941
942 (defun parse-id (lstream decl-type)
943 (let ((id (look lstream)))
944 (if (identifierp id)
945 (progn
946 (consume lstream)
947 (values decl-type id))
948 (values decl-type nil))))
949
950 ;;; Processes multi-dimensional arrays too
951 (defun parse-array (lstream decl-type)
952 (let* ((dimension-tok (consume lstream)) ; Eat [
953 (dimension (if (eq dimension-tok '|]|)
954 nil
955 (parse-expression lstream))))
956 (if (not (eq (look lstream) '|]|))
957 (cparse-error "Malformed array: expected ], got ~S" (look lstream)))
958 (make-instance 'array-type
959 :len dimension
960 :of (if (eq (consume lstream) '|[|)
961 (parse-array lstream decl-type)
962 decl-type))))
963
964 (defun parse-function (lstream decl-type)
965 (consume lstream) ;Eat (
966 (let ((args (parse-function-args lstream)))
967 (consume lstream)
968 (make-instance 'func-type
969 :return-type decl-type
970 :args (if (and (eql (length args) 1)
971 (typep (caar args) 'cparse-void))
972 nil
973 args))))
974
975 (defun parse-func-decl-type (lstream)
976 (if (eq (look lstream) '|.|)
977 (if (and (eq (consume lstream) '|.|)
978 (eq (consume lstream) '|.|))
979 (progn
980 (consume lstream)
981 (make-instance 'stdarg-type))
982 (cparse-error "Malformed function argument. Token: ~S~%"
983 (look lstream)))
984 (parse-decl-type lstream)))
985
986 (defun parse-function-args (lstream)
987 (if (eq (look lstream) '|)|)
988 (progn
989 (return-from parse-function-args nil)))
990 (loop
991 for decl-type = (parse-func-decl-type lstream)
992 collect (multiple-value-list (parse-declarator lstream decl-type))
993 do (case (look lstream)
994 (|,| (consume lstream))
995 (|)| (loop-finish))
996 (t (cparse-error "Unexpected token at end of function args: ~S"
997 (look lstream))))))
998
999 ;;; lookahead token is either |union| or |struct|
1000 (defun parse-struct-union (lstream)
1001 (let* ((type-class (if (eq (look lstream) '|struct|)
1002 'struct-type
1003 'union-type))
1004 (maybe-compound-tag (consume lstream))
1005 (compound-tag (and (identifierp maybe-compound-tag)
1006 maybe-compound-tag))
1007 (defined-type (or (and compound-tag
1008 (lookup 'struct-tags compound-tag))
1009 (make-instance type-class
1010 :tag compound-tag
1011 :outer-scope *current-scope*))))
1012 (when compound-tag
1013 (consume lstream))
1014 (when (eq (look lstream) '{)
1015 (cond ((null defined-type)
1016 (setf defined-type (make-instance type-class)))
1017 ((slot-boundp defined-type 'members)
1018 (cparse-error "Multiple definitions of struct/union ~S"
1019 compound-tag)))
1020 (let ((*current-scope* defined-type))
1021 (with-slots (members size alignment) defined-type
1022 (setf members (parse-struct-members lstream))
1023 (multiple-value-bind (siz align offsets)
1024 (compute-compound-size defined-type)
1025 (setf size siz
1026 alignment align)
1027 (setf members (add-elems-to-lists offsets members))))))
1028 defined-type))
1029
1030 (defun add-elems-to-lists (elems lists)
1031 (loop for list on lists
1032 for head = elems then next
1033 for next = (cdr elems) then (cdr next)
1034 do (progn
1035 (setf (cdr head) nil)
1036 (setf (car list) (nconc (car list) head))))
1037 lists)
1038
1039
1040 (defun round-to-alignment (addr align)
1041 (* (ceiling addr align) align))
1042
1043 (defgeneric compute-compound-size (type))
1044
1045 (defmethod compute-compound-size ((type struct-type))
1046 (loop for (decl) in (members type)
1047 for decl-size = (sizeof decl)
1048 for decl-align = (alignof decl)
1049 for decl-offset = 0 then (round-to-alignment struct-size decl-align)
1050 for struct-size = decl-size then (+ decl-offset decl-size)
1051 maximize decl-align into max-alignment
1052 collect decl-offset into member-offsets
1053 finally (return (values (round-to-alignment struct-size max-alignment)
1054 max-alignment
1055 member-offsets))))
1056
1057 (defmethod compute-compound-size ((type union-type))
1058 (loop for (decl) in (members type)
1059 for decl-size = (sizeof decl)
1060 for decl-align = (alignof decl)
1061 maximize decl-align into max-alignment
1062 maximize decl-size into union-size
1063 collect 0 into member-offsets
1064 finally (return (values (round-to-alignment union-size max-alignment)
1065 max-alignment
1066 member-offsets))))
1067
1068 (defun parse-struct-members (lstream)
1069 (consume lstream) ; Eat {
1070 (loop
1071 append (prog1
1072 (cparse-stmt lstream)
1073 (consume lstream)) ; Eat ;
1074 until (eq (look lstream) '|}|)
1075 finally (consume lstream)))
1076
1077 (defun parse-enum (lstream)
1078 (consume lstream) ; Eat enum
1079 (let ((maybe-enum-tag (look lstream)))
1080 (when (identifierp maybe-enum-tag)
1081 (let ((existing-enum (lookup 'struct-tags maybe-enum-tag)))
1082 (when existing-enum
1083 (if (typep existing-enum 'enum-type)
1084 (return-from parse-enum existing-enum)
1085 (cparse-error "~S is not an enum tag."
1086 maybe-enum-tag)))))
1087 (let ((enum (make-instance 'enum-type)))
1088 (when (identifierp maybe-enum-tag)
1089 (setf (tag enum) maybe-enum-tag)
1090 (setf (get-scope 'struct-tags maybe-enum-tag) enum)
1091 (consume lstream))
1092 (unless (eq '{ (look lstream))
1093 (cparse-error "In enum definition expected { but got ~S~%"
1094 (look lstream)))
1095 (setf (enumerators enum) (parse-enumerators lstream))
1096 enum)))
1097
1098 (defun parse-enumerators (lstream)
1099 (consume lstream) ; Eat {
1100 (let ((enum-val 0))
1101 (flet ((parse-one-enum ()
1102 (let ((id (look lstream)))
1103 (when (eq id '})
1104 (consume lstream)
1105 (return-from parse-one-enum nil))
1106 (unless (identifierp id)
1107 (cparse-error "expected an identifier, but got ~S~%" id))
1108 (let ((seperator (consume lstream)))
1109 (when (eq seperator '=)
1110 (consume lstream)
1111 (let ((enum-val-obj (parse-expression lstream)))
1112 (unless (typep enum-val-obj 'int-const) ;XXX
1113 (cparse-error "non-integral expression in enum: ~S~%"
1114 enum-val))
1115 (setq enum-val (value enum-val-obj)))
1116 (setf seperator (look lstream)))
1117 (if (or (eq seperator '|,|) (eq seperator '}))
1118 (progn
1119 (when (eq seperator '|,|)
1120 (consume lstream))
1121 (prog1 `(,id . ,enum-val)
1122 (incf enum-val)))
1123 (cparse-error "In enum, expected , or } but got ~S~%"
1124 seperator))))))
1125 (loop for enum-def = (parse-one-enum)
1126 while enum-def
1127 collect enum-def))))
1128
1129 (defun cparse-string (str &rest args &key &allow-other-keys)
1130 "Parse string STR. See cparse-stream for other arguments."
1131 (with-input-from-string (str-stream str)
1132 (apply #'cparse-stream str-stream args)))
1133
1134 (defun cparse-file (file-name &rest args &key &allow-other-keys)
1135 "Parse the contents of file FILE-NAME. See cparse-stream for other
1136 arguments."
1137 (with-open-file (stream file-name)
1138 (apply #'cparse-stream stream :file-name file-name args)))
1139
1140 (defgeneric do-statement (implementation statement))
1141
1142 (defclass cmucl-implementation (cparse-object)
1143 ())
1144
1145 (defmethod do-statement ((implementation cmucl-implementation) statement)
1146 (print statement))
1147
1148 ;;; parser for constant C expressions. Whee!
1149
1150 ;;; An expression in the parse tree. We'll have to make this up as we
1151 ;;; go along...
1152
1153 (defc cexpr (cparse-object)
1154 ())
1155
1156 (defc cast-expr (cexpr)
1157 ((explicit-type)
1158 (expr)))
1159
1160 (defc address-expr (cexpr)
1161 ((base)
1162 (index)))
1163
1164 (defc pointer-expr (cexpr)
1165 ((address)))
1166
1167 (defc struct-ref-expr (cexpr)
1168 ((base)
1169 (slot)))
1170
1171 (defc union-ref-expr (cexpr)
1172 ((base)
1173 (slot)))
1174
1175 (defun eat-or-error (sym lstream)
1176 (unless (eq sym (look lstream))
1177 (cparse-error "Expected token ~A, but got ~A" sym (look lstream)))
1178 (consume lstream))
1179
1180 (defun parse-expression (lstream)
1181 (conditional-expression lstream))
1182
1183 ;;; Parse operators at a certain precedence.
1184
1185 (defmacro def-expr-expression (expr-fun term-fun op-list)
1186 (let ((op-alist (mapcar #'(lambda (op)
1187 (cons (car op) (cadr op)))
1188 op-list)))
1189 `(let ((op-alist ',op-alist))
1190 (defun ,expr-fun (lstream)
1191 (loop
1192 with result = (,term-fun lstream)
1193 for op = (look lstream)
1194 for op-fun = (cdr (assoc op op-alist))
1195 for term = (when op-fun
1196 (consume lstream)
1197 (,term-fun lstream))
1198 while op-fun
1199 do (setq result (funcall op-fun *compiler-implementation*
1200 result term))
1201 finally (return result))))))
1202
1203 (def-expr-expression mult-expression parse-cast-expression
1204 ((* c*) (/ c/)))
1205 (def-expr-expression add-expression mult-expression ((+ c+) (- c-)))
1206 (def-expr-expression shift-expression add-expression ((>> c>>) (<< c<<)))
1207 (def-expr-expression relational-expression shift-expression
1208 ((> c>) (< c<) (>= c>=) (<= c<=)))
1209 (def-expr-expression equality-expression relational-expression
1210 ((== c=) (!= c!=)))
1211 (def-expr-expression and-expression equality-expression ((& c&)))
1212 (def-expr-expression exclusive-or-expression and-expression ((^ c-logxor)))
1213 (def-expr-expression inclusive-or-expression exclusive-or-expression
1214 ((\| c-logior)))
1215 (def-expr-expression logical-and-expression inclusive-or-expression
1216 ((&& c-and)))
1217 (def-expr-expression logical-or-expression logical-and-expression
1218 ((\|\| c-or)))
1219
1220 (defun conditional-expression (lstream)
1221 (let ((term (logical-or-expression lstream)))
1222 (if (eql (look lstream) '?)
1223 (progn
1224 (consume lstream)
1225 (let ((true-case (parse-expression lstream)))
1226 (eat-or-error '|:| lstream)
1227 (let ((false-case (conditional-expression lstream)))
1228 (if (zerop term)
1229 false-case
1230 true-case))))
1231 term)))
1232
1233 (defun parse-cast-expression (lstream)
1234 (let ((initial (look lstream)))
1235 (cond ((eq initial '|(|)
1236 (consume lstream)
1237 (if (maybe-type-name lstream)
1238 (let ((decl (parse-type-name lstream)))
1239 (eat-or-error '|)| lstream)
1240 (make-instance 'cast-expr :explicit-type decl
1241 :expr (parse-cast-expression lstream)))
1242 (progn
1243 (push-back '|(| lstream)
1244 (parse-unary-expression lstream))))
1245 (t (parse-unary-expression lstream)))))
1246
1247 (defun parse-unary-expression (lstream)
1248 (let ((initial (look lstream)))
1249 (cond ((eq initial '|sizeof|)
1250 (parse-sizeof lstream))
1251 ((eq initial '+)
1252 (parse-cast-expression lstream))
1253 ((eq initial '-)
1254 (cneg *compiler-implementation* (parse-cast-expression lstream)))
1255 ((eq initial '~)
1256 (c~ *compiler-implementation* (parse-cast-expression lstream)))
1257 ((eq initial '!)
1258 (c! *compiler-implementation* (parse-cast-expression lstream)))
1259 ((or (eq initial '*) (eq initial '&))
1260 (cparse-error "Can't parse ~A yet." initial))
1261 ((or (eq initial '++) (eq initial '--))
1262 (cparse-error
1263 "increment or decrement operator not allowed in a constant
1264 expression."))
1265 (t (parse-postfix-expression lstream)))))
1266
1267 (defun parse-postfix-expression (lstream)
1268 (let ((current-expr (parse-primary-expression lstream)))
1269 (loop for postfix-tok = (look lstream)
1270 while (member postfix-tok '(|[| |(| |.| -> ++ --) :test #'eq)
1271 do (case postfix-tok
1272 (|[|
1273 (consume lstream)
1274 (let ((array-expr (parse-expression lstream)))
1275 (eat-or-error '|]| lstream)
1276 (setq current-expr
1277 (make-instance
1278 'pointer-expr
1279 :address (make-instance 'address-expr
1280 :base current-expr
1281 :index array-expr)))))
1282 (t
1283 (cparse-error "Can't parse ~A yet" postfix-tok)))
1284 finally (return current-expr))))
1285
1286 (defun parse-primary-expression (lstream)
1287 (let ((initial (look lstream)))
1288 (cond ((eql initial '|(|)
1289 (consume lstream)
1290 (multiple-value-prog1 (parse-expression lstream)
1291 (when (not (eql '|)| (look lstream)))
1292 (cparse-error "Didn't see closing parens on expression"))
1293 (consume lstream))) ; eat ')
1294 ;; XXX This should do the right thing with unsigned and
1295 ;; integer constants...
1296 ((typep initial 'c-const)
1297 (consume lstream)
1298 initial)
1299 (t (cparse-error "Can't parse ~S" initial)))))
1300
1301 ;;; See if the token could be part of a type name
1302
1303 (defun maybe-type-name (lstream)
1304 (let ((tok (look lstream)))
1305 (or (member tok +decl-keywords+)
1306 (member tok '(|struct| |union| |enum|))
1307 (let ((maybe-typedef-type (lookup 'objects tok)))
1308 (typep maybe-typedef-type 'typedef-type)))))
1309
1310 (defun parse-type-name (lstream)
1311 (let ((decl-type (parse-decl-type lstream)))
1312 (multiple-value-bind (declarator id)
1313 (parse-declarator lstream decl-type)
1314 (when id
1315 (cparse-error "type name has id ~A" id))
1316 declarator)))
1317
1318 (defun parse-sizeof (lstream)
1319 (let* ((initial (consume lstream))
1320 (sized-type (cond ((eq initial '|(|)
1321 (consume lstream)
1322 (if (maybe-type-name lstream)
1323 (prog1
1324 (parse-type-name lstream)
1325 (eat-or-error '|)| lstream))
1326 (progn
1327 (push-back initial lstream)
1328 (parse-unary-expression lstream))))
1329 (t (parse-unary-expression lstream)))))
1330 (make-instance 'int-const :value (sizeof sized-type))))
1331
1332 (defgeneric sizeof (type))
1333
1334 (defgeneric alignof (type))
1335
1336 ;;; The default - get the typewidth from ctype.lisp
1337 (defmethod sizeof ((type c-type))
1338 (/ (type-width *compiler-implementation* type) 8))
1339
1340 (defmethod alignof ((type c-type))
1341 (/ (type-alignment *compiler-implementation* type) 8))
1342
1343 (defmethod sizeof ((type compound-type))
1344 (size type))
1345
1346 (defmethod alignof ((type compound-type))
1347 (alignment type))
1348
1349 (defparameter *a-pointer* (make-instance 'pointer-type))
1350
1351 (defmethod sizeof ((type array-type))
1352 (if (len type)
1353 (* (sizeof (of type)) (value (len type)))
1354 (sizeof *a-pointer*)))
1355
1356 (defmethod alignof ((type array-type))
1357 (alignof (of type)))
1358
1359 (defmethod sizeof ((type pointer-type))
1360 (/ (pointer-width *compiler-implementation*) 8))
1361
1362 (defmethod alignof ((type pointer-type))
1363 (/ (pointer-alignment *compiler-implementation*) 8))
1364
1365 (let ((dummy-int (make-instance 'int)))
1366 (defmethod sizeof ((type enum-type))
1367 (/ (type-width *compiler-implementation* dummy-int) 8))
1368 (defmethod alignof ((type enum-type))
1369 (/ (type-alignment *compiler-implementation* dummy-int) 8)))
1370
1371 ;;; For testing
1372 (defun cparse-const (stream)
1373 (let ((lstream (make-instance 'lookahead-stream :stream stream)))
1374 (values (parse-expression lstream) (look lstream))))
1375
1376 (defun test-const (str)
1377 (with-input-from-string (stream str)
1378 (cparse-const stream)))

  ViewVC Help
Powered by ViewVC 1.1.5