3 ;;; Protocol for C type representation
5 ;;; (c) 2009 Straylight/Edgeware
8 ;;;----- Licensing notice ---------------------------------------------------
10 ;;; This file is part of the Sensible Object Design, an object system for C.
12 ;;; SOD is free software; you can redistribute it and/or modify
13 ;;; it under the terms of the GNU General Public License as published by
14 ;;; the Free Software Foundation; either version 2 of the License, or
15 ;;; (at your option) any later version.
17 ;;; SOD is distributed in the hope that it will be useful,
18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;;; GNU General Public License for more details.
22 ;;; You should have received a copy of the GNU General Public License
23 ;;; along with SOD; if not, write to the Free Software Foundation,
24 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
28 ;;;--------------------------------------------------------------------------
29 ;;; Root classes and common access protocol.
31 ;; It seems more useful to put the root class here, so that we can provide
32 ;; methods specialized on it, e.g., PRINT-OBJECT.
38 "Base class for C type objects."))
40 (export '(qualifiable-c-type c-type-qualifiers))
41 (defclass qualifiable-c-type (c-type)
42 ((qualifiers :initarg :qualifiers :initform nil
43 :type list :reader c-type-qualifiers))
45 "Base class for C types which can be qualified."))
47 (export 'canonify-qualifiers)
48 (defun canonify-qualifiers (qualifiers)
49 "Return a canonical list of qualifiers.
51 Duplicates and `nil' entries are deleted, and the remaining entries are
53 (sort (delete-duplicates (delete nil (copy-list qualifiers))) #'string<))
55 (export 'qualify-c-type)
56 (defgeneric qualify-c-type (type qualifiers)
58 "Return a type like TYPE but with the specified QUALIFIERS.
60 The qualifiers of the returned type are the union of the requested
61 QUALIFIERS and the qualifiers already applied to TYPE."))
63 (export 'c-qualifier-keyword)
64 (defgeneric c-qualifier-keyword (qualifier)
65 (:documentation "Return the C keyword for the QUALIFIER (a Lisp keyword).")
66 (:method ((qualifier symbol)) (string-downcase qualifier)))
68 (export 'c-type-qualifier-keywords)
69 (defun c-type-qualifier-keywords (c-type)
70 "Return the type's qualifiers, as a list of C keyword names."
71 (mapcar #'c-qualifier-keyword (c-type-qualifiers c-type)))
73 (export 'c-type-subtype)
74 (defgeneric c-type-subtype (type)
76 "For compound types, return the base type."))
78 ;;;--------------------------------------------------------------------------
79 ;;; Comparison protocol.
81 (export 'c-type-equal-p)
82 (defgeneric c-type-equal-p (type-a type-b)
83 (:method-combination and)
85 "Answers whether two types TYPE-A and TYPE-B are structurally equal.
87 Here, `structurally equal' means that they have the same qualifiers,
88 similarly spelt names, and structurally equal components.")
89 (:method and (type-a type-b)
90 (eql (class-of type-a) (class-of type-b))))
92 (defmethod c-type-equal-p and ((type-a qualifiable-c-type)
93 (type-b qualifiable-c-type))
94 (equal (canonify-qualifiers (c-type-qualifiers type-a))
95 (canonify-qualifiers (c-type-qualifiers type-b))))
97 ;;;--------------------------------------------------------------------------
98 ;;; C syntax output protocol.
100 (export 'pprint-c-type)
101 (defgeneric pprint-c-type (type stream kernel)
103 "Pretty-printer for C types.
105 Print TYPE to STREAM. In the middle of the declarator, call the function
106 KERNEL with one argument: whether it needs a leading space.")
107 (:method :around (type stream kernel)
109 (null (pprint-c-type type stream
110 (lambda (stream prio spacep)
111 (declare (ignore stream prio spacep))
113 ((or function symbol) (call-next-method))
114 (t (pprint-c-type type stream
115 (lambda (stream prio spacep)
116 (declare (ignore prio))
118 (c-type-space stream))
119 (princ kernel stream)))))))
121 (export 'c-type-space)
122 (defun c-type-space (stream)
123 "Print a space and a miser-mode newline to STREAM.
125 This is the right function to call in a `pprint-c-type' kernel function
126 when the SPACEP argument is true."
127 (pprint-indent :block 2 stream)
128 (write-char #\space stream)
129 (pprint-newline :miser stream))
131 (defun maybe-in-parens* (stream condition thunk)
132 "Helper function for the `maybe-in-parens' macro."
133 (multiple-value-bind (prefix suffix)
134 (if condition (values "(" ")") (values "" ""))
135 (pprint-logical-block (stream nil :prefix prefix :suffix suffix)
136 (funcall thunk stream))))
138 (export 'maybe-in-parens)
139 (defmacro maybe-in-parens ((stream condition) &body body)
140 "Evaluate BODY; if CONDITION, write parens to STREAM around it.
142 This macro is useful for implementing the `pprint-c-type' method on
143 compound types. The BODY is evaluated in the context of a logical block
144 printing to STREAM. If CONDITION is non-nil, then the block will have
145 open/close parens as its prefix and suffix; otherwise they will be empty.
147 The STREAM is passed to `pprint-logical-block', so it must be a symbol."
148 `(maybe-in-parens* ,stream ,condition (lambda (,stream) ,@body)))
150 (export 'format-qualifiers)
151 (defun format-qualifiers (quals)
152 "Return a string listing QUALS, with a space after each."
153 (format nil "~{~(~A~) ~}" quals))
155 ;;;--------------------------------------------------------------------------
156 ;;; S-expression notation protocol.
158 (export 'print-c-type)
159 (defgeneric print-c-type (stream type &optional colon atsign)
161 "Print an abbreviated syntax for TYPE to the STREAM.
163 This function is suitable for use in `format's ~/.../ command."))
165 (export '(expand-c-type-spec expand-c-type-form))
166 (eval-when (:compile-toplevel :load-toplevel :execute)
167 (defgeneric expand-c-type-spec (spec)
168 (:documentation "Expand SPEC into Lisp code to construct a C type.")
169 (:method ((spec list))
170 (expand-c-type-form (car spec) (cdr spec))))
171 (defgeneric expand-c-type-form (head tail)
172 (:documentation "Expand a C type list beginning with HEAD.")
173 (:method ((name (eql 'lisp)) tail)
177 (defmacro c-type (spec)
178 "Expands to code to construct a C type, using `expand-c-type-spec'."
179 (expand-c-type-spec spec))
181 (export 'define-c-type-syntax)
182 (defmacro define-c-type-syntax (name bvl &body body)
183 "Define a C-type syntax function.
185 A function defined by BODY and with lambda-list BVL is associated with the
186 NAME. When `expand-c-type-spec' sees a list (NAME . STUFF), it will call
187 this function with the argument list STUFF."
188 (with-gensyms (head tail)
189 (multiple-value-bind (doc decls body) (parse-body body)
190 `(eval-when (:compile-toplevel :load-toplevel :execute)
191 (defmethod expand-c-type-form ((,head (eql ',name)) ,tail)
193 (destructuring-bind ,bvl ,tail
195 (block ,name ,@body)))
198 (export 'c-type-alias)
199 (defmacro c-type-alias (original &rest aliases)
200 "Make ALIASES behave the same way as the ORIGINAL type."
201 (with-gensyms (head tail)
202 `(eval-when (:compile-toplevel :load-toplevel :execute)
203 ,@(mapcar (lambda (alias)
204 `(defmethod expand-c-type-form
205 ((,head (eql ',alias)) ,tail)
206 (expand-c-type-form ',original ,tail)))
211 (defmacro defctype (names value &key export)
212 "Define NAMES all to describe the C-type VALUE.
214 NAMES can be a symbol (treated as a singleton list), or a list of symbols.
215 The VALUE is a C type S-expression, acceptable to `expand-c-type-spec'.
216 It will be expanded once at run-time."
217 (let* ((names (if (listp names) names (list names)))
218 (namevar (gensym "NAME"))
219 (typevar (symbolicate 'c-type- (car names))))
222 `((export '(,typevar ,@names))))
223 (defparameter ,typevar ,(expand-c-type-spec value))
224 (eval-when (:compile-toplevel :load-toplevel :execute)
225 ,@(mapcar (lambda (name)
226 `(defmethod expand-c-type-spec ((,namevar (eql ',name)))
231 (export 'c-name-case)
232 (defun c-name-case (name)
233 "Convert NAME to suitable case.
235 Strings are returned as-is; symbols are squashed to lower-case and hyphens
236 are replaced by underscores."
238 (symbol (with-output-to-string (out)
239 (loop for ch across (symbol-name name)
240 do (cond ((alpha-char-p ch)
241 (write-char (char-downcase ch) out))
242 ((or (digit-char-p ch)
246 (write-char #\_ out))
248 (error "Bad character in C name ~S" name))))))
251 ;;;--------------------------------------------------------------------------
252 ;;; Storage specifier protocol.
254 (export 'pprint-c-storage-specifier)
255 (defgeneric pprint-c-storage-specifier (spec stream)
256 (:documentation "Print the storage specifier SPEC to STREAM, as C syntax.")
257 (:method ((spec symbol) stream) (princ (string-downcase spec) stream)))
259 (export 'print-c-storage-specifier)
260 (defgeneric print-c-storage-specifier (stream spec &optional colon atsign)
262 "Print the storage specifier SPEC to STREAM, as an S-expression.
264 This function is suitable for use in `format's ~/.../ command.")
265 (:method (stream (spec t) &optional colon atsign)
266 (declare (ignore colon atsign))
268 (:method (stream (spec symbol) &optional colon atsign)
269 (declare (ignore colon atsign))
270 (princ (string-downcase spec) stream)))
272 (export '(expand-c-storage-specifier expand-c-storage-specifier-form))
273 (eval-when (:compile-toplevel :load-toplevel :execute)
274 (defgeneric expand-c-storage-specifier (spec)
276 "Expand SPEC into Lisp code to construct a storage specifier.")
277 (:method ((spec list))
278 (expand-c-storage-specifier-form (car spec) (cdr spec)))
279 (:method ((spec symbol))
280 (if (keywordp spec) spec
281 (expand-c-storage-specifier-form spec nil))))
282 (defgeneric expand-c-storage-specifier-form (head tail)
284 "Expand a C storage-specifier form beginning with HEAD.")
285 (:method ((name (eql 'lisp)) tail)
288 (export 'define-c-storage-specifier-syntax)
289 (defmacro define-c-storage-specifier-syntax (name bvl &body body)
290 "Define a C storage-specifier syntax function.
292 A function defined by BODY and with lambda-list BVL is associated wth the
293 NAME. When `expand-c-storage-specifier' sees a list (NAME . STUFF), it
294 will call this function with the argument list STUFF."
295 (with-gensyms (head tail)
296 (multiple-value-bind (doc decls body) (parse-body body)
297 `(eval-when (:compile-toplevel :load-toplevel :execute)
298 (defmethod expand-c-storage-specifier-form
299 ((,head (eql ',name)) ,tail)
301 (destructuring-bind ,bvl ,tail
303 (block ,name ,@body)))
306 ;;;--------------------------------------------------------------------------
307 ;;; A type for carrying storage specifiers.
309 (export '(c-storage-specifiers-type c-type-specifiers))
310 (defclass c-storage-specifiers-type (c-type)
311 ((specifiers :initarg :specifiers :type list :reader c-type-specifiers)
312 (subtype :initarg :subtype :type c-type :reader c-type-subtype))
314 "A type for carrying storage specifiers.
316 Properly, storage specifiers should only appear on an outermost type.
317 This fake C type is a handy marker for the presence of storage specifiers,
318 so that they can be hoisted properly when constructing derived types."))
320 (export 'wrap-c-type)
321 (defun wrap-c-type (wrapper-func base-type)
322 "Handle storage specifiers correctly when making a derived type.
324 WRAPPER-FUNC should be a function which will return some derived type of
325 BASE-TYPE. This function differs from `funcall' only when BASE-TYPE is
326 actually a `c-storage-specifiers-type', in which case it invokes
327 WRAPPER-FUNC on the underlying type, and re-attaches the storage
328 specifiers to the derived type."
329 (if (typep base-type 'c-storage-specifiers-type)
330 (let* ((unwrapped-type (c-type-subtype base-type))
331 (wrapped-type (funcall wrapper-func unwrapped-type))
332 (specifiers (c-type-specifiers base-type)))
333 (make-or-intern-c-type 'c-storage-specifiers-type unwrapped-type
334 :specifiers specifiers
335 :subtype wrapped-type))
336 (funcall wrapper-func base-type)))
338 ;;;--------------------------------------------------------------------------
339 ;;; Function arguments.
341 (export '(argument argumentp make-argument
342 argument-name argument-type argument-default))
343 (defstruct (argument (:constructor make-argument (name type &optional default
345 (:predicate argumentp))
346 "Simple structure representing a function argument."
347 (name nil :type t :read-only t)
348 (%type nil :type c-type :read-only t)
349 (default nil :type t :read-only t))
350 (define-access-wrapper argument-type argument-%type :read-only t)
352 (export 'commentify-argument-name)
353 (defgeneric commentify-argument-name (name)
355 "Produce a `commentified' version of the argument.
357 The default behaviour is that temporary argument names are simply omitted
358 (nil is returned); otherwise, `/*...*/' markers are wrapped around the
359 printable representation of the argument.")
360 (:method ((name null)) nil)
361 (:method ((name t)) (format nil "/*~A*/" name)))
363 ;;;--------------------------------------------------------------------------
364 ;;; Printing objects.
366 (defmethod print-object ((object c-type) stream)
368 (format stream "~:@<C-TYPE ~/sod:print-c-type/~:>" object)
369 (pprint-c-type object stream nil)))
371 ;;;----- That's all, folks --------------------------------------------------