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

Contents of /cparse/ctype.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: +33 -13 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 ;;; Numeric types in C. This file implements the representation of and
29 ;;; arithmetic on types, but the types themselves can be used in
30 ;;; classes that represent parse trees, variables and such.
31
32 (in-package "CPARSE")
33
34 (defclass c-super ()
35 ())
36
37
38 (defmethod print-object ((obj c-super) stream)
39 (let ((slots (mapcan #'(lambda (slot-def)
40 (let ((name
41 #+PCL (pcl:slot-definition-name slot-def)
42 #+allegro (mop:slot-definition-name slot-def)))
43 (if (slot-boundp obj name)
44 (list name (slot-value obj name))
45 nil)))
46 #+PCL (pcl:class-slots (class-of obj))
47 #+allegro (mop:class-slots (class-of obj)))))
48 (print-unreadable-object (obj stream :type t)
49 (format stream "~<~@{~W ~@_~W~^ ~_~}~:>" slots))))
50
51 (defclass void (c-super)
52 ())
53
54 (defclass c-const (c-super)
55 ((value :accessor value :initarg :value)))
56
57 (defmacro defnumtype (cname super &body body)
58 "Define class CNAME with superclasses SUPER and CNAME-CONST with superclasses
59 \(,@SUPER c-const\)"
60 (let ((const-name (intern (concatenate 'string
61 (symbol-name cname)
62 (symbol-name '-const)))))
63 `(progn
64 (defclass ,cname ,super ,@body)
65 (defclass ,const-name (,cname c-const) ,@body))))
66
67 (defclass unsigned ()
68 ())
69
70 (defclass cinteger-super ()
71 ())
72
73 (defnumtype byte (cinteger-super)
74 ())
75
76 (defnumtype unsigned-byte (unsigned byte)
77 ())
78
79 (defnumtype short (cinteger-super)
80 ())
81
82 (defnumtype unsigned-short (unsigned short)
83 ())
84
85 (defnumtype int (cinteger-super)
86 ())
87
88 (defnumtype unsigned-int (unsigned int)
89 ())
90
91 (defnumtype long (cinteger-super)
92 ())
93
94 (defnumtype unsigned-long (unsigned long)
95 ())
96
97 (defnumtype long-long (cinteger-super)
98 ())
99
100 (defnumtype unsigned-long-long (unsigned long-long)
101 ())
102
103 (defclass cfloat-super ()
104 ())
105
106 (defnumtype cfloat (cfloat-super)
107 ())
108
109 (defnumtype double (cfloat-super)
110 ())
111
112 (defnumtype char ()
113 ())
114
115 (defnumtype signed-char ()
116 ())
117
118 (defnumtype unsigned-char (unsigned char)
119 ())
120
121 ;;; Is a type unsigned? For characters this is defined by the
122 ;;; implementation, so put it into a generic function.
123
124 (defgeneric unsignedp (comp-imp type))
125
126 (defmethod unsignedp (comp-imp (type t))
127 (declare (ignore comp-imp))
128 nil)
129
130 (defmethod unsignedp (comp-imp (type unsigned))
131 (declare (ignore comp-imp))
132 t)
133
134 (defgeneric max-val (comp-imp type))
135
136 (defmethod max-val (comp-imp (type cinteger-super))
137 (1- (expt 2 (1- (type-width comp-imp type)))))
138
139 (defmethod min-val (comp-imp (type cinteger-super))
140 (- (expt 2 (1- (type-width comp-imp type)))))
141
142 (defmethod max-val (comp-imp (type unsigned))
143 (1- (expt 2 (type-width comp-imp type))))
144
145 (defmethod min-val (comp-imp (type unsigned))
146 (declare (ignore comp-imp))
147 0)
148
149 ;;; Class representing C compiler implementation characteristics.
150 ;;; This includes whether or not char is signed and the widths of each type.
151
152 (defclass compiler-impl (c-super)
153 ())
154
155 (defgeneric type-width (comp-imp type))
156
157 ;;; fallback - this is bad but shouldn't halt generation
158 (defmethod type-width (comp-imp type)
159 (warn "Type ~A is too complex for `type-width' - substituting 0!" type)
160 0)
161
162 (defmethod type-width ((comp-imp compiler-impl) (type char))
163 8)
164
165 (defmethod type-width ((comp-imp compiler-impl) (type unsigned-char))
166 8)
167
168 (defun truncate-with-sign (val width)
169 "Utility function to truncate a Lisp integer VAL of width WIDTH. The sign
170 bit is extended."
171 (let ((truncated (ldb (byte width 0) val)))
172 (if (logbitp (1- width) val)
173 (logior (ash -1 32) truncated)
174 truncated)))
175
176
177
178 (defclass impl-32bit (compiler-impl)
179 ())
180
181 (defmethod unsignedp ((comp-imp impl-32bit) (type char))
182 t)
183
184 (defmethod unsignedp ((comp-imp impl-32bit) (type signed-char))
185 nil)
186
187 (defmethod type-width ((comp-imp impl-32bit) (type short))
188 16)
189
190 (defmethod type-width ((comp-imp impl-32bit) (type int))
191 32)
192
193 (defmethod type-width ((comp-imp impl-32bit) (type long))
194 32)
195
196 (defmethod type-width ((comp-imp impl-32bit) (type long-long))
197 64)
198
199 (defmethod type-width ((comp-imp impl-32bit) (type cfloat))
200 32)
201
202 (defmethod type-width ((comp-imp impl-32bit) (type double))
203 64)
204
205 ;;; XXX Hack to avoid dealing with pointer types at this level
206 (defgeneric pointer-width (comp-imp))
207
208 (defmethod pointer-width ((comp-imp impl-32bit))
209 32)
210
211 (defgeneric pointer-alignment (comp-imp))
212
213 (defmethod pointer-alignment ((comp-imp impl-32bit))
214 32)
215
216 (defgeneric type-alignment (comp-imp type))
217
218 (defmethod type-alignment ((comp-imp impl-32bit) (type t))
219 (type-width comp-imp type))
220
221 (defmethod type-alignment ((comp-imp impl-32bit) (type long-long))
222 32)
223
224 (defvar *target-compiler* (make-instance 'impl-32bit))
225
226 ;;; Type promotion
227 ;;; Avoid writing two versions of every method
228
229 (defconstant +type-precedence+
230 '(int-const unsigned-int-const long-const unsigned-long-const
231 long-long-const unsigned-long-long-const cfloat-const double-const))
232
233 (defun convert-operands (cimpl op1 op2)
234 (let* ((real-op1 (promote cimpl op1))
235 (real-op2 (promote cimpl op2))
236 (op1-prec (position (type-of real-op1) +type-precedence+))
237 (op2-prec (position (type-of real-op2) +type-precedence+)))
238 (cond ((eql op1-prec op2-prec)
239 (values real-op1 real-op2))
240 ((> op1-prec op2-prec)
241 (convert-operand-type cimpl real-op1 real-op2))
242 (t (multiple-value-bind (new-op2 new-op1)
243 (convert-operand-type cimpl real-op2 real-op1)
244 (values new-op1 new-op2))))))
245
246 (defgeneric promote (cimpl cval))
247
248 (defmethod promote ((cimpl impl-32bit) (cval t))
249 cval)
250
251 (defmethod promote ((cimpl impl-32bit) (cval char-const))
252 (make-instance 'int-const :value (value cval)))
253
254 (defmethod promote ((cimpl impl-32bit) (cval unsigned-char-const))
255 (make-instance 'int-const :value (value cval)))
256
257 (defmethod promote ((cimpl impl-32bit) (cval short-const))
258 (make-instance 'int-const :value (value cval)))
259
260 (defmethod promote ((cimpl impl-32bit) (cval unsigned-short-const))
261 (make-instance 'int-const :value (value cval)))
262
263 ;;; Convert op2 to the type of op1
264 (defgeneric convert-operand-type (cimpl op1 op2))
265
266 (defmethod convert-operand-type ((cimpl impl-32bit) (op1 double-const) op2)
267 (values op1
268 (make-instance 'double-const
269 :value (float (value op2) (value op1)))))
270
271 (defmethod convert-operand-type ((cimpl impl-32bit) (op1 cfloat-const) op2)
272 (values op1
273 (make-instance 'cfloat-const
274 :value (float (value op2) (value op1)))))
275
276 (defmethod convert-operand-type ((cimpl impl-32bit)
277 (op1 unsigned-long-const) op2)
278 (values op1
279 (make-instance 'unsigned-long-const
280 :value (ldb (byte 32 0) (value op2)))))
281
282 ;;; Long can't accommodate all unsigned values, so both operands get converted
283 ;;; to unsigned long.
284 (defun convert-long-to-unsigned (cimpl op1 op2 promote-class)
285 (values (make-instance promote-class
286 :value (ldb (byte (type-width cimpl op1) 0)
287 (value op1)))
288 (make-instance promote-class
289 :value (ldb (byte (type-width cimpl op2) 0)
290 (value op2)))))
291
292 (defmethod convert-operand-type ((cimpl impl-32bit)
293 (op1 long-const) (op2 unsigned))
294 (convert-long-to-unsigned cimpl op1 op2 'unsigned-long-const))
295
296 (defmethod convert-operand-type ((cimpl impl-32bit) (op1 long-const) op2)
297 (values op1 (make-instance 'long-const :value (value op2))))
298
299 (defmethod convert-operand-type ((cimpl impl-32bit)
300 (op1 long-long-const) (op2 unsigned))
301 (convert-long-to-unsigned cimpl op1 op2 'unsigned-long-long-const))
302
303 (defmethod convert-operand-type ((cimpl impl-32bit)
304 (op1 unsigned-int-const) op2)
305 (values op1
306 (make-instance 'unsigned-int-const
307 :value (ldb (byte 32 0) (value op2)))))
308
309 ;;; Sanity check: if the first operand is an int, the second better be too.
310 (defmethod convert-operand-type ((cimpl impl-32bit)
311 (op1 int-const) (op2 int-const))
312 (values op1 op2))
313
314 ;;; Make types compatible before doing arithmetic
315
316 (defun c+ (cimpl op1 op2)
317 (multiple-value-bind (op1-converted op2-converted)
318 (convert-operands cimpl op1 op2)
319 (c+-internal cimpl op1-converted op2-converted)))
320
321 (defgeneric c+-internal (cimpl op1 op2))
322
323 (defmethod c+-internal ((cimpl impl-32bit)
324 (op1 double-const) (op2 double-const))
325 (make-instance 'double-const :value (+ (value op1) (value op2))))
326
327 (defmethod c+-internal ((cimpl impl-32bit)
328 (op1 cfloat-const) (op2 cfloat-const))
329 (make-instance 'cfloat-const :value (+ (value op1) (value op2))))
330
331 ;;; Shortcuts so we don't have to write methods for all the integer types
332 (defmethod c+-internal ((cimpl impl-32bit) (op1 unsigned) (op2 unsigned))
333 (let ((bytespec (byte (type-width cimpl op1) 0))
334 (result (+ (value op1) (value op2))))
335 (make-instance (class-of op1) :value (ldb bytespec result))))
336
337 (defmethod c+-internal ((cimpl impl-32bit)
338 (op1 cinteger-super)
339 (op2 cinteger-super))
340 (let ((result (+ (value op1) (value op2))))
341 (make-instance (class-of op1)
342 :value (truncate-with-sign result
343 (type-width cimpl op1)))))
344
345 (defmacro def-c-op (c-func float-func int-func)
346 (let ((internal-op (intern (concatenate 'simple-string
347 (string c-func)
348 (symbol-name '-internal))
349 :cparse)))
350 `(progn
351 (defun ,c-func (cimpl op1 op2)
352 (multiple-value-bind (op1-converted op2-converted)
353 (convert-operands cimpl op1 op2)
354 (,internal-op cimpl op1-converted op2-converted)))
355 (defgeneric ,internal-op (cimpl op1 op2))
356 ,@(when float-func
357 `((defmethod ,internal-op ((cimpl impl-32bit)
358 (op1 double-const) (op2 double-const))
359 (make-instance 'double-const
360 :value (,float-func (value op1) (value op2))))
361 (defmethod ,internal-op ((cimpl impl-32bit)
362 (op1 cfloat-const) (op2 cfloat-const))
363 (make-instance 'cfloat-const
364 :value (,float-func (value op1) (value op2))))))
365 ;; Shortcuts so we don't have to write methods for all the integer types
366 ,@(when int-func
367 `((defmethod ,internal-op ((cimpl impl-32bit) (op1 unsigned)
368 (op2 unsigned))
369 (let ((bytespec (byte (type-width cimpl op1) 0))
370 (result (,int-func (value op1) (value op2))))
371 (make-instance (class-of op1) :value (ldb bytespec result))))
372 (defmethod ,internal-op ((cimpl impl-32bit)
373 (op1 cinteger-super)
374 (op2 cinteger-super))
375 (let ((result (,int-func (value op1) (value op2))))
376 (make-instance (class-of op1)
377 :value
378 (truncate-with-sign result
379 (type-width cimpl
380 op1))))))))))
381
382
383 (def-c-op c- - -)
384 (def-c-op c* * *)
385 (def-c-op c/ / truncate)
386 (def-c-op c>> nil (lambda (x y) (ash x (- y))))
387 (def-c-op c<< nil (lambda (x y) (ash x y)))
388
389 (macrolet ((frob-boolean-op (op)
390 (let ((generic-name (intern (concatenate 'string
391 "C" (symbol-name op))))
392 (internal-name (intern (concatenate 'string
393 "%C"
394 (symbol-name op)))))
395 `(progn
396 (defun ,internal-name (x y)
397 (if (,op x y) 1 0))
398 (def-c-op ,generic-name ,internal-name ,internal-name)))))
399 (frob-boolean-op >)
400 (frob-boolean-op <)
401 (frob-boolean-op <=)
402 (frob-boolean-op >=)
403 (frob-boolean-op =))
404
405 (def-c-op c!=
406 (lambda (x y) (if (not (= x y)) 1 0))
407 (lambda (x y) (if (not (= x y)) 1 0)))
408
409 (def-c-op c& nil (lambda (x y) (logand x y)))
410 (def-c-op c-logxor nil (lambda (x y) (logxor x y)))
411 (def-c-op c-logior nil (lambda (x y) (logior x y)))
412 (def-c-op c-and nil (lambda (x y)
413 (if (and (not (= x 0)) (not (= y 0)))
414 1
415 0)))
416 (def-c-op c-or nil (lambda (x y)
417 (if (or (not (= x 0)) (not (= y 0)))
418 1
419 0)))
420
421 ;;; Unary ops
422
423 (defun cneg (cimpl op)
424 (cneg-internal cimpl op))
425
426 (defgeneric cneg-internal (cimpl op))
427
428 (defmethod cneg-internal (cimpl (op c-const))
429 (declare (ignore cimpl))
430 (make-instance (class-of op) :value (- (value op))))
431
432 (defun c! (cimpl op)
433 (c!-internal cimpl op))
434
435 (defgeneric c!-internal (cimpl op))
436
437 (defmethod c!-internal (cimpl (op c-const))
438 (declare (ignore cimpl))
439 (make-instance 'int-const
440 :value (if (= (value op) 0)
441 1
442 0)))
443
444 (defun c~ (cimpl op)
445 (c~-internal cimpl op))
446
447 (defgeneric c~-internal (cimpl op))
448
449 (defmethod c~-internal (cimpl (op cinteger-super))
450 (make-instance (class-of op)
451 :value (truncate-with-sign (lognot (value op))
452 (type-width cimpl op))))

  ViewVC Help
Powered by ViewVC 1.1.5