| 1 | ;;; -*-lisp-*- |
| 2 | ;;; |
| 3 | ;;; C type representation implementation |
| 4 | ;;; |
| 5 | ;;; (c) 2009 Straylight/Edgeware |
| 6 | ;;; |
| 7 | |
| 8 | ;;;----- Licensing notice --------------------------------------------------- |
| 9 | ;;; |
| 10 | ;;; This file is part of the Sensible Object Design, an object system for C. |
| 11 | ;;; |
| 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. |
| 16 | ;;; |
| 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. |
| 21 | ;;; |
| 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. |
| 25 | |
| 26 | (cl:in-package #:sod) |
| 27 | |
| 28 | ;;;-------------------------------------------------------------------------- |
| 29 | ;;; Interning types. |
| 30 | |
| 31 | (defparameter *c-type-intern-map* (make-hash-table :test #'equal) |
| 32 | "Hash table mapping lists describing types to their distinguished |
| 33 | representations.") |
| 34 | |
| 35 | (defun intern-c-type (class &rest initargs) |
| 36 | "If the CLASS and INITARGS have already been interned, then return the |
| 37 | existing object; otherwise make a new one." |
| 38 | (let ((list (cons (typecase class |
| 39 | ;; Canonify the class object; we'd prefer a name. |
| 40 | (standard-class (class-name class)) |
| 41 | (t class)) |
| 42 | (let ((alist nil) (plist initargs)) |
| 43 | ;; Canonify the initargs. Arrange for them to be in |
| 44 | ;; ascending order by name. This is annoying because |
| 45 | ;; a plist isn't a readily sortable sequence. |
| 46 | (loop |
| 47 | (when (null plist) (return)) |
| 48 | (let ((name (pop plist)) (value (pop plist))) |
| 49 | (push (cons name value) alist))) |
| 50 | (dolist (assoc (sort alist #'string> :key #'car)) |
| 51 | (push (cdr assoc) plist) |
| 52 | (push (car assoc) plist)) |
| 53 | plist)))) |
| 54 | (or (gethash list *c-type-intern-map*) |
| 55 | (let ((new (apply #'make-instance class initargs))) |
| 56 | (setf (gethash new *c-type-intern-map*) t |
| 57 | (gethash list *c-type-intern-map*) new))))) |
| 58 | |
| 59 | #+test |
| 60 | (defun check-type-intern-map () |
| 61 | "Sanity check for the type-intern map." |
| 62 | (let ((map (make-hash-table))) |
| 63 | |
| 64 | ;; Pass 1: check that interned types are consistent with their keys. |
| 65 | ;; Remember interned types. |
| 66 | (maphash (lambda (k v) |
| 67 | (when (listp k) |
| 68 | (let ((ty (apply #'make-instance k))) |
| 69 | (assert (c-type-equal-p ty v))) |
| 70 | (setf (gethash v map) t))) |
| 71 | *c-type-intern-map*) |
| 72 | |
| 73 | ;; Pass 2: check that the interned type indicators are correct. |
| 74 | (maphash (lambda (k v) |
| 75 | (declare (ignore v)) |
| 76 | (assert (gethash k *c-type-intern-map*))) |
| 77 | map) |
| 78 | (maphash (lambda (k v) |
| 79 | (declare (ignore v)) |
| 80 | (when (typep k 'c-type) |
| 81 | (assert (gethash k map)))) |
| 82 | *c-type-intern-map*))) |
| 83 | |
| 84 | (defun make-or-intern-c-type (new-type-class base-types &rest initargs) |
| 85 | "Return a possibly-new instance of NEW-TYPE-CLASS with the given INITARGS. |
| 86 | |
| 87 | If all of the BASE-TYPES are interned, then use `intern-c-type' to |
| 88 | construct the new type; otherwise just make a new one with |
| 89 | `make-instance'. BASE-TYPES may be a singleton type, or a sequence of |
| 90 | types." |
| 91 | (apply (if (if (typep base-types 'sequence) |
| 92 | (every (lambda (type) |
| 93 | (gethash type *c-type-intern-map*)) |
| 94 | base-types) |
| 95 | (gethash base-types *c-type-intern-map*)) |
| 96 | #'intern-c-type #'make-instance) |
| 97 | new-type-class |
| 98 | initargs)) |
| 99 | |
| 100 | ;;;-------------------------------------------------------------------------- |
| 101 | ;;; Qualifiers. |
| 102 | |
| 103 | (defmethod c-qualifier-keyword ((qualifier (eql :atomic))) "_Atomic") |
| 104 | |
| 105 | (defmethod qualify-c-type ((type qualifiable-c-type) qualifiers) |
| 106 | (let ((initargs (instance-initargs type))) |
| 107 | (remf initargs :qualifiers) |
| 108 | (apply #'make-or-intern-c-type (class-of type) type |
| 109 | :qualifiers (canonify-qualifiers |
| 110 | (append qualifiers (c-type-qualifiers type))) |
| 111 | initargs))) |
| 112 | |
| 113 | ;;;-------------------------------------------------------------------------- |
| 114 | ;;; Storage specifiers. |
| 115 | |
| 116 | (defmethod c-type-equal-p :around |
| 117 | ((type-a c-storage-specifiers-type) (type-b c-type)) |
| 118 | "Ignore storage specifiers when comparing C types." |
| 119 | (c-type-equal-p (c-type-subtype type-a) type-b)) |
| 120 | |
| 121 | (defmethod c-type-equal-p :around |
| 122 | ((type-a c-type) (type-b c-storage-specifiers-type)) |
| 123 | "Ignore storage specifiers when comparing C types." |
| 124 | (c-type-equal-p type-a (c-type-subtype type-b))) |
| 125 | |
| 126 | (defun make-storage-specifiers-type (subtype specifiers) |
| 127 | "Construct a type based on SUBTYPE, carrying the storage SPECIFIERS." |
| 128 | (if (null specifiers) subtype |
| 129 | (make-or-intern-c-type 'c-storage-specifiers-type subtype |
| 130 | :specifiers specifiers |
| 131 | :subtype subtype))) |
| 132 | |
| 133 | (defmethod pprint-c-type ((type c-storage-specifiers-type) stream kernel) |
| 134 | (dolist (spec (c-type-specifiers type)) |
| 135 | (pprint-c-storage-specifier spec stream) |
| 136 | (write-char #\space stream) |
| 137 | (pprint-newline :miser stream)) |
| 138 | (pprint-c-type (c-type-subtype type) stream kernel)) |
| 139 | |
| 140 | (defmethod print-c-type |
| 141 | (stream (type c-storage-specifiers-type) &optional colon atsign) |
| 142 | (declare (ignore colon atsign)) |
| 143 | (format stream "~:@<SPECS ~@_~:I~/sod:print-c-type/~ |
| 144 | ~{ ~_~/sod:print-c-storage-specifier/~}~:>" |
| 145 | (c-type-subtype type) (c-type-specifiers type))) |
| 146 | |
| 147 | (export 'specs) |
| 148 | (define-c-type-syntax specs (subtype &rest specifiers) |
| 149 | `(make-storage-specifiers-type |
| 150 | ,(expand-c-type-spec subtype) |
| 151 | (list ,@(mapcar #'expand-c-storage-specifier specifiers)))) |
| 152 | |
| 153 | ;;;-------------------------------------------------------------------------- |
| 154 | ;;; Some storage specifiers. |
| 155 | |
| 156 | (export 'alignas-storage-specifier) |
| 157 | (defclass alignas-storage-specifier () |
| 158 | ((alignment :initarg :alignment :reader spec-alignment))) |
| 159 | |
| 160 | (export 'alignas) |
| 161 | (define-c-storage-specifier-syntax alignas (alignment) |
| 162 | `(make-instance 'alignas-storage-specifier :alignment ,alignment)) |
| 163 | |
| 164 | (defmethod print-c-storage-specifier |
| 165 | (stream (spec alignas-storage-specifier) &optional colon atsign) |
| 166 | (declare (ignore colon atsign)) |
| 167 | (format stream "~:@<~S ~_~S~:>" 'alignas (spec-alignment spec))) |
| 168 | |
| 169 | (defmethod pprint-c-storage-specifier |
| 170 | ((spec alignas-storage-specifier) stream) |
| 171 | (format stream "_Alignas(~A)" (spec-alignment spec))) |
| 172 | |
| 173 | ;;;-------------------------------------------------------------------------- |
| 174 | ;;; Simple C types. |
| 175 | |
| 176 | ;; Class definition. |
| 177 | |
| 178 | (export '(simple-c-type c-type-name)) |
| 179 | (defclass simple-c-type (qualifiable-c-type) |
| 180 | ((name :initarg :name :type string :reader c-type-name)) |
| 181 | (:documentation |
| 182 | "C types with simple forms.")) |
| 183 | |
| 184 | ;; Constructor function and interning. |
| 185 | |
| 186 | (export 'make-simple-type) |
| 187 | (defun make-simple-type (name &optional qualifiers) |
| 188 | "Make a distinguished object for the simple type called NAME." |
| 189 | (intern-c-type 'simple-c-type |
| 190 | :name name |
| 191 | :qualifiers (canonify-qualifiers qualifiers))) |
| 192 | |
| 193 | ;; Comparison protocol. |
| 194 | |
| 195 | (defmethod c-type-equal-p and |
| 196 | ((type-a simple-c-type) (type-b simple-c-type)) |
| 197 | (string= (c-type-name type-a) (c-type-name type-b))) |
| 198 | |
| 199 | ;; C syntax output protocol. |
| 200 | |
| 201 | (defmethod pprint-c-type ((type simple-c-type) stream kernel) |
| 202 | (pprint-logical-block (stream nil) |
| 203 | (format stream "~{~A ~@_~}~A" |
| 204 | (c-type-qualifier-keywords type) |
| 205 | (c-type-name type)) |
| 206 | (funcall kernel stream 0 t))) |
| 207 | |
| 208 | ;; S-expression notation protocol. |
| 209 | |
| 210 | (defparameter *simple-type-map* (make-hash-table :test #'equal) |
| 211 | "Hash table mapping strings of C syntax to symbolic names.") |
| 212 | |
| 213 | (defmethod print-c-type (stream (type simple-c-type) &optional colon atsign) |
| 214 | (declare (ignore colon atsign)) |
| 215 | (let* ((name (c-type-name type)) |
| 216 | (symbol (gethash name *simple-type-map*))) |
| 217 | (format stream "~:[~S~;~:@<~S~0@*~{ ~_~S~}~:>~]" |
| 218 | (c-type-qualifiers type) (or symbol name)))) |
| 219 | |
| 220 | (eval-when (:compile-toplevel :load-toplevel :execute) |
| 221 | (defmethod expand-c-type-spec ((spec string)) |
| 222 | `(make-simple-type ,spec)) |
| 223 | (defmethod expand-c-type-form ((head string) tail) |
| 224 | `(make-simple-type ,head (list ,@tail)))) |
| 225 | |
| 226 | (export 'define-simple-c-type) |
| 227 | (defmacro define-simple-c-type (names type &key export) |
| 228 | "Define each of NAMES to be a simple type called TYPE." |
| 229 | (let ((names (if (listp names) names (list names))) |
| 230 | (types (if (listp type) type (list type)))) |
| 231 | (with-gensyms (type name) |
| 232 | `(progn |
| 233 | (dolist (,type ',types) |
| 234 | (setf (gethash ,type *simple-type-map*) ',(car names))) |
| 235 | (dolist (,name ',names) |
| 236 | (setf (gethash ,name *simple-type-map*) ,(car types))) |
| 237 | (defctype ,names ,(car types) :export ,export) |
| 238 | (define-c-type-syntax ,(car names) (&rest quals) |
| 239 | `(make-simple-type ,',(car types) (list ,@quals))))))) |
| 240 | |
| 241 | (export 'find-simple-c-type) |
| 242 | (defun find-simple-c-type (name) |
| 243 | "Return the `simple-c-type' with the given NAME, or nil." |
| 244 | (aand (gethash name *simple-type-map*) |
| 245 | (make-simple-type (gethash it *simple-type-map*)))) |
| 246 | |
| 247 | ;; Built-in C types. |
| 248 | |
| 249 | (define-simple-c-type void "void" :export t) |
| 250 | |
| 251 | (define-simple-c-type char "char" :export t) |
| 252 | (define-simple-c-type (unsigned-char uchar) "unsigned char" :export t) |
| 253 | (define-simple-c-type (signed-char schar) "signed char" :export t) |
| 254 | (define-simple-c-type wchar-t "wchar_t" :export t) |
| 255 | |
| 256 | (define-simple-c-type (int signed signed-int sint) "int" :export t) |
| 257 | (define-simple-c-type (unsigned unsigned-int uint) "unsigned" :export t) |
| 258 | |
| 259 | (define-simple-c-type (short signed-short short-int signed-short-int sshort) |
| 260 | "short" :export t) |
| 261 | (define-simple-c-type (unsigned-short unsigned-short-int ushort) |
| 262 | "unsigned short" :export t) |
| 263 | |
| 264 | (define-simple-c-type (long signed-long long-int signed-long-int slong) |
| 265 | "long" :export t) |
| 266 | (define-simple-c-type (unsigned-long unsigned-long-int ulong) |
| 267 | "unsigned long" :export t) |
| 268 | |
| 269 | (define-simple-c-type (long-long signed-long-long long-long-int |
| 270 | signed-long-long-int llong sllong) |
| 271 | "long long" :export t) |
| 272 | (define-simple-c-type (unsigned-long-long unsigned-long-long-int ullong) |
| 273 | "unsigned long long" :export t) |
| 274 | |
| 275 | (define-simple-c-type float "float" :export t) |
| 276 | (define-simple-c-type double "double" :export t) |
| 277 | (define-simple-c-type long-double "long double" :export t) |
| 278 | |
| 279 | (define-simple-c-type bool ("_Bool" "bool") :export t) |
| 280 | |
| 281 | (define-simple-c-type float-complex "float _Complex" :export t) |
| 282 | (define-simple-c-type double-complex "double _Complex" :export t) |
| 283 | (define-simple-c-type long-double-complex "long double _Complex" :export t) |
| 284 | |
| 285 | (define-simple-c-type float-imaginary "float _Imaginary" :export t) |
| 286 | (define-simple-c-type double-imaginary "double _Imaginary" :export t) |
| 287 | (define-simple-c-type long-double-imaginary |
| 288 | "long double _Imaginary" :export t) |
| 289 | |
| 290 | (define-simple-c-type va-list "va_list" :export t) |
| 291 | (define-simple-c-type size-t "size_t" :export t) |
| 292 | (define-simple-c-type ptrdiff-t "ptrdiff_t" :export t) |
| 293 | |
| 294 | ;;;-------------------------------------------------------------------------- |
| 295 | ;;; Tagged types (enums, structs and unions). |
| 296 | |
| 297 | ;; Class definition. |
| 298 | |
| 299 | (export '(tagged-c-type c-type-tag)) |
| 300 | (defclass tagged-c-type (qualifiable-c-type) |
| 301 | ((tag :initarg :tag :type string :reader c-type-tag)) |
| 302 | (:documentation |
| 303 | "C types with tags.")) |
| 304 | |
| 305 | ;; Subclass definitions. |
| 306 | |
| 307 | (export 'c-tagged-type-kind) |
| 308 | (defgeneric c-tagged-type-kind (type) |
| 309 | (:documentation |
| 310 | "Return the kind of tagged type that TYPE is, as a keyword.")) |
| 311 | |
| 312 | (export 'kind-c-tagged-type) |
| 313 | (defgeneric kind-c-tagged-type (kind) |
| 314 | (:documentation |
| 315 | "Given a keyword KIND, return the appropriate class name.")) |
| 316 | |
| 317 | (export 'make-c-tagged-type) |
| 318 | (defun make-c-tagged-type (kind tag &optional qualifiers) |
| 319 | "Return a tagged type with the given KIND (keyword) and TAG (string)." |
| 320 | (intern-c-type (kind-c-tagged-type kind) |
| 321 | :tag tag |
| 322 | :qualifiers (canonify-qualifiers qualifiers))) |
| 323 | |
| 324 | (macrolet ((define-tagged-type (kind what) |
| 325 | (let* ((type (symbolicate 'c- kind '-type)) |
| 326 | (keyword (intern (symbol-name kind) :keyword)) |
| 327 | (constructor (symbolicate 'make- kind '-type))) |
| 328 | `(progn |
| 329 | (export '(,type ,kind ,constructor)) |
| 330 | (defclass ,type (tagged-c-type) () |
| 331 | (:documentation ,(format nil "C ~A types." what))) |
| 332 | (defmethod c-tagged-type-kind ((type ,type)) |
| 333 | ',keyword) |
| 334 | (defmethod kind-c-tagged-type ((kind (eql ',keyword))) |
| 335 | ',type) |
| 336 | (defun ,constructor (tag &optional qualifiers) |
| 337 | (intern-c-type ',type :tag tag |
| 338 | :qualifiers (canonify-qualifiers |
| 339 | qualifiers))) |
| 340 | (define-c-type-syntax ,kind (tag &rest quals) |
| 341 | ,(format nil "Construct ~A type named TAG" what) |
| 342 | `(,',constructor ,tag (list ,@quals))))))) |
| 343 | (define-tagged-type enum "enumerated") |
| 344 | (define-tagged-type struct "structure") |
| 345 | (define-tagged-type union "union")) |
| 346 | |
| 347 | ;; Comparison protocol. |
| 348 | |
| 349 | (defmethod c-type-equal-p and ((type-a tagged-c-type) (type-b tagged-c-type)) |
| 350 | (string= (c-type-tag type-a) (c-type-tag type-b))) |
| 351 | |
| 352 | ;; C syntax output protocol. |
| 353 | |
| 354 | (defmethod pprint-c-type ((type tagged-c-type) stream kernel) |
| 355 | (pprint-logical-block (stream nil) |
| 356 | (format stream "~{~A ~@_~}~(~A~) ~A" |
| 357 | (c-type-qualifier-keywords type) |
| 358 | (c-tagged-type-kind type) |
| 359 | (c-type-tag type)) |
| 360 | (funcall kernel stream 0 t))) |
| 361 | |
| 362 | ;; S-expression notation protocol. |
| 363 | |
| 364 | (defmethod print-c-type (stream (type tagged-c-type) &optional colon atsign) |
| 365 | (declare (ignore colon atsign)) |
| 366 | (format stream "~:@<~S ~@_~S~{ ~_~S~}~:>" |
| 367 | (c-tagged-type-kind type) |
| 368 | (c-type-tag type) |
| 369 | (c-type-qualifiers type))) |
| 370 | |
| 371 | ;;;-------------------------------------------------------------------------- |
| 372 | ;;; Atomic types. |
| 373 | |
| 374 | ;; Class definition. |
| 375 | |
| 376 | (export 'c-atomic-type) |
| 377 | (defclass c-atomic-type (qualifiable-c-type) |
| 378 | ((subtype :initarg :subtype :type c-type :reader c-type-subtype)) |
| 379 | (:documentation "C atomic types.")) |
| 380 | |
| 381 | ;; Constructor function. |
| 382 | |
| 383 | (export 'make-atomic-type) |
| 384 | (defun make-atomic-type (subtype &optional qualifiers) |
| 385 | "Return a (maybe distinguished) atomic type." |
| 386 | (make-or-intern-c-type 'c-atomic-type subtype |
| 387 | :subtype subtype |
| 388 | :qualifiers (canonify-qualifiers qualifiers))) |
| 389 | |
| 390 | ;; Comparison protocol. |
| 391 | |
| 392 | (defmethod c-type-equal-p and ((type-a c-atomic-type) (type-b c-atomic-type)) |
| 393 | (c-type-equal-p (c-type-subtype type-a) (c-type-subtype type-b))) |
| 394 | |
| 395 | ;; C-syntax output protocol. |
| 396 | |
| 397 | (defmethod pprint-c-type ((type c-atomic-type) stream kernel) |
| 398 | (pprint-logical-block (stream nil) |
| 399 | (format stream "~{~A ~@_~}" (c-type-qualifier-keywords type)) |
| 400 | (write-string "_Atomic(" stream) |
| 401 | (pprint-indent :current 0 stream) |
| 402 | (pprint-c-type (c-type-subtype type) stream |
| 403 | (lambda (stream prio spacep) |
| 404 | (declare (ignore stream prio spacep)))) |
| 405 | (write-char #\) stream))) |
| 406 | |
| 407 | ;; S-expression notation protocol. |
| 408 | |
| 409 | (defmethod print-c-type (stream (type c-atomic-type) &optional colon atsign) |
| 410 | (declare (ignore colon atsign)) |
| 411 | (format stream "~:@<ATOMIC ~@_~/sod:print-c-type/~{ ~_~S~}~:>" |
| 412 | (c-type-subtype type) |
| 413 | (c-type-qualifiers type))) |
| 414 | |
| 415 | (export 'atomic) |
| 416 | (define-c-type-syntax atomic (sub &rest quals) |
| 417 | "Return the type of atomic SUB." |
| 418 | `(make-atomic-type ,(expand-c-type-spec sub) (list ,@quals))) |
| 419 | |
| 420 | ;;;-------------------------------------------------------------------------- |
| 421 | ;;; Pointer types. |
| 422 | |
| 423 | ;; Class definition. |
| 424 | |
| 425 | (export 'c-pointer-type) |
| 426 | (defclass c-pointer-type (qualifiable-c-type) |
| 427 | ((subtype :initarg :subtype :type c-type :reader c-type-subtype)) |
| 428 | (:documentation "C pointer types.")) |
| 429 | |
| 430 | ;; Constructor function. |
| 431 | |
| 432 | (export 'make-pointer-type) |
| 433 | (defun make-pointer-type (subtype &optional qualifiers) |
| 434 | "Return a (maybe distinguished) pointer type." |
| 435 | (make-or-intern-c-type 'c-pointer-type subtype |
| 436 | :subtype subtype |
| 437 | :qualifiers (canonify-qualifiers qualifiers))) |
| 438 | |
| 439 | ;; Comparison protocol. |
| 440 | |
| 441 | (defmethod c-type-equal-p and ((type-a c-pointer-type) |
| 442 | (type-b c-pointer-type)) |
| 443 | (c-type-equal-p (c-type-subtype type-a) (c-type-subtype type-b))) |
| 444 | |
| 445 | ;; C syntax output protocol. |
| 446 | |
| 447 | (defmethod pprint-c-type ((type c-pointer-type) stream kernel) |
| 448 | (pprint-c-type (c-type-subtype type) stream |
| 449 | (lambda (stream prio spacep) |
| 450 | (when spacep (c-type-space stream)) |
| 451 | (maybe-in-parens (stream (> prio 1)) |
| 452 | (format stream "*~{~A~^ ~@_~}" |
| 453 | (c-type-qualifier-keywords type)) |
| 454 | (funcall kernel stream 1 (c-type-qualifiers type)))))) |
| 455 | |
| 456 | ;; S-expression notation protocol. |
| 457 | |
| 458 | (defmethod print-c-type (stream (type c-pointer-type) &optional colon atsign) |
| 459 | (declare (ignore colon atsign)) |
| 460 | (format stream "~:@<* ~@_~/sod:print-c-type/~{ ~_~S~}~:>" |
| 461 | (c-type-subtype type) |
| 462 | (c-type-qualifiers type))) |
| 463 | |
| 464 | (export '(* pointer ptr)) |
| 465 | (define-c-type-syntax * (sub &rest quals) |
| 466 | "Return the type of pointer-to-SUB." |
| 467 | `(make-pointer-type ,(expand-c-type-spec sub) (list ,@quals))) |
| 468 | (c-type-alias * pointer ptr) |
| 469 | |
| 470 | ;; Built-in C types. |
| 471 | |
| 472 | (export '(string const-string)) |
| 473 | (defctype string (* char)) |
| 474 | (defctype const-string (* (char :const))) |
| 475 | |
| 476 | ;;;-------------------------------------------------------------------------- |
| 477 | ;;; Array types. |
| 478 | |
| 479 | ;; Class definition. |
| 480 | |
| 481 | (export '(c-array-type c-array-dimensions)) |
| 482 | (defclass c-array-type (c-type) |
| 483 | ((subtype :initarg :subtype :type c-type :reader c-type-subtype) |
| 484 | (dimensions :initarg :dimensions :type list :reader c-array-dimensions)) |
| 485 | (:documentation |
| 486 | "C array types.")) |
| 487 | |
| 488 | ;; Constructor function. |
| 489 | |
| 490 | (export 'make-array-type) |
| 491 | (defun make-array-type (subtype dimensions) |
| 492 | "Return a new array of SUBTYPE with given DIMENSIONS." |
| 493 | (make-instance 'c-array-type :subtype subtype |
| 494 | :dimensions (or dimensions '(nil)))) |
| 495 | |
| 496 | ;; Comparison protocol. |
| 497 | |
| 498 | (defmethod c-type-equal-p and ((type-a c-array-type) (type-b c-array-type)) |
| 499 | |
| 500 | ;; Messy. C doesn't have multidimensional arrays, but we fake them for |
| 501 | ;; convenience's sake. But it means that we have to arrange for |
| 502 | ;; multidimensional arrays to equal vectors of vectors -- and in general |
| 503 | ;; for multidimensional arrays of multidimensional arrays to match each |
| 504 | ;; other properly, even when their dimensions don't align precisely. |
| 505 | (labels ((check (sub-a dim-a sub-b dim-b) |
| 506 | (cond ((endp dim-a) |
| 507 | (cond ((endp dim-b) |
| 508 | (c-type-equal-p sub-a sub-b)) |
| 509 | ((typep sub-a 'c-array-type) |
| 510 | (check (c-type-subtype sub-a) |
| 511 | (c-array-dimensions sub-a) |
| 512 | sub-b dim-b)) |
| 513 | (t |
| 514 | nil))) |
| 515 | ((endp dim-b) |
| 516 | (check sub-b dim-b sub-a dim-a)) |
| 517 | ((equal (car dim-a) (car dim-b)) |
| 518 | (check sub-a (cdr dim-a) sub-b (cdr dim-b))) |
| 519 | (t |
| 520 | nil)))) |
| 521 | (check (c-type-subtype type-a) (c-array-dimensions type-a) |
| 522 | (c-type-subtype type-b) (c-array-dimensions type-b)))) |
| 523 | |
| 524 | ;; C syntax output protocol. |
| 525 | |
| 526 | (defmethod pprint-c-type ((type c-array-type) stream kernel) |
| 527 | (pprint-c-type (c-type-subtype type) stream |
| 528 | (lambda (stream prio spacep) |
| 529 | (maybe-in-parens (stream (> prio 2)) |
| 530 | (funcall kernel stream 2 spacep) |
| 531 | (format stream "~@<~{[~@[~A~]]~^~_~}~:>" |
| 532 | (c-array-dimensions type)))))) |
| 533 | |
| 534 | ;; S-expression notation protocol. |
| 535 | |
| 536 | (defmethod print-c-type (stream (type c-array-type) &optional colon atsign) |
| 537 | (declare (ignore colon atsign)) |
| 538 | (format stream "~:@<[] ~@_~:I~/sod:print-c-type/~{ ~_~S~}~:>" |
| 539 | (c-type-subtype type) |
| 540 | (c-array-dimensions type))) |
| 541 | |
| 542 | (export '([] array vec)) |
| 543 | (define-c-type-syntax [] (sub &rest dims) |
| 544 | "Return the type of arrays of SUB with the dimensions DIMS. |
| 545 | |
| 546 | If the DIMS are omitted, a single unknown-length dimension is added." |
| 547 | `(make-array-type ,(expand-c-type-spec sub) |
| 548 | (list ,@(or dims '(nil))))) |
| 549 | (c-type-alias [] array vec) |
| 550 | |
| 551 | ;;;-------------------------------------------------------------------------- |
| 552 | ;;; Function types. |
| 553 | |
| 554 | ;; Function arguments. |
| 555 | |
| 556 | (defun argument-lists-equal-p (list-a list-b) |
| 557 | "Return whether LIST-A and LIST-B match. |
| 558 | |
| 559 | They must have the same number of arguments, and each argument must have |
| 560 | the same type, or be `:ellipsis'. The argument names are not inspected." |
| 561 | (and (= (length list-a) (length list-b)) |
| 562 | (every (lambda (arg-a arg-b) |
| 563 | (if (eq arg-a :ellipsis) |
| 564 | (eq arg-b :ellipsis) |
| 565 | (and (argumentp arg-a) (argumentp arg-b) |
| 566 | (c-type-equal-p (argument-type arg-a) |
| 567 | (argument-type arg-b))))) |
| 568 | list-a list-b))) |
| 569 | |
| 570 | (defun fix-and-check-keyword-argument-list (list) |
| 571 | "Check the keyword argument LIST is valid; if so, fix it up and return it. |
| 572 | |
| 573 | Check that the keyword arguments have distinct names. Fix the list up by |
| 574 | sorting it by keyword name." |
| 575 | |
| 576 | (unless (every #'argumentp list) |
| 577 | (error "(INTERNAL) not an argument value")) |
| 578 | |
| 579 | (let ((list (sort (copy-list list) #'string< :key #'argument-name))) |
| 580 | (do ((list (cdr list) (cdr list)) |
| 581 | (this (car list) (car list)) |
| 582 | (prev nil this)) |
| 583 | ((endp list)) |
| 584 | (when prev |
| 585 | (let ((this-name (argument-name this)) |
| 586 | (prev-name (argument-name prev))) |
| 587 | (when (string= this-name prev-name) |
| 588 | (error "Duplicate keyword argument name `~A'" this-name))))) |
| 589 | list)) |
| 590 | |
| 591 | (export 'merge-keyword-lists) |
| 592 | (defun merge-keyword-lists (whatfn lists) |
| 593 | "Return the union of keyword argument lists. |
| 594 | |
| 595 | The WHATFN is either nil or a designator for a function (see below). |
| 596 | |
| 597 | The LISTS parameter consists of pairs (REPORTFN . ARGS), where REPORTFN is |
| 598 | either nil or a designator for a function (see below); and and ARGS is a |
| 599 | list of `argument' objects. |
| 600 | |
| 601 | The resulting list contains exactly one argument for each distinct |
| 602 | argument name appearing in the input lists; this argument will contain the |
| 603 | default value corresponding to the name's earliest occurrence in the input |
| 604 | LISTS. |
| 605 | |
| 606 | If the same name appears in multiple input lists with different types, a |
| 607 | continuable error is signalled. |
| 608 | |
| 609 | The WHATFN function is given no arguments, and is expected to return a |
| 610 | file location (or other object convertible with `file-location'), and a |
| 611 | string (or other printable object) describing the site at which the |
| 612 | keyword argument lists are being merged or nil; a mismatch error will be |
| 613 | reported as being at the location returned by WHATFN, and the description |
| 614 | will be included in the error message. A nil WHATFN is equivalent to a |
| 615 | function which returns a nil location and description, though this is |
| 616 | considered poor practice. |
| 617 | |
| 618 | The REPORTFN is given a single argument ARG, which is one of the |
| 619 | conflicting `argument' objects found in the REPORTFN's corresponding |
| 620 | argument list: the REPORTFN is expected to issue additional `info' |
| 621 | messages to help the user diagnose the problem. The (common) name of the |
| 622 | argument has already been reported. A nil REPORTFN is equivalent to one |
| 623 | which does nothing, though this is considered poor practice." |
| 624 | |
| 625 | ;; The easy way through all of this is with a hash table mapping argument |
| 626 | ;; names to (WHAT . ARG) pairs. |
| 627 | |
| 628 | (let ((argmap (make-hash-table :test #'equal))) |
| 629 | |
| 630 | ;; Set up the table. When we find a duplicate, check that the types |
| 631 | ;; match. |
| 632 | (dolist (item lists) |
| 633 | (let ((reportfn (car item)) |
| 634 | (args (cdr item))) |
| 635 | (dolist (arg args) |
| 636 | (let* ((name (argument-name arg)) |
| 637 | (other-item (gethash name argmap))) |
| 638 | (if (null other-item) |
| 639 | (setf (gethash name argmap) (cons reportfn arg)) |
| 640 | (let* ((type (argument-type arg)) |
| 641 | (other-reportfn (car other-item)) |
| 642 | (other (cdr other-item)) |
| 643 | (other-type (argument-type other))) |
| 644 | (unless (c-type-equal-p type other-type) |
| 645 | (multiple-value-bind (floc desc) |
| 646 | (if whatfn (funcall whatfn) (values nil nil)) |
| 647 | (cerror*-with-location floc |
| 648 | "Type mismatch for keyword ~ |
| 649 | argument `~A'~@[ in ~A~]" |
| 650 | name desc) |
| 651 | (when reportfn |
| 652 | (funcall reportfn arg)) |
| 653 | (when other-reportfn |
| 654 | (funcall other-reportfn other)))))))))) |
| 655 | |
| 656 | ;; Now it's just a matter of picking the arguments out again. |
| 657 | (let ((result nil)) |
| 658 | (maphash (lambda (name item) |
| 659 | (declare (ignore name)) |
| 660 | (push (cdr item) result)) |
| 661 | argmap) |
| 662 | (fix-and-check-keyword-argument-list result)))) |
| 663 | |
| 664 | ;; Class definition. |
| 665 | |
| 666 | (export '(c-function-type c-function-arguments)) |
| 667 | (defclass c-function-type (c-type) |
| 668 | ((subtype :initarg :subtype :type c-type :reader c-type-subtype) |
| 669 | (arguments :type list :reader c-function-arguments)) |
| 670 | (:documentation |
| 671 | "C function types. The subtype is the return type, as implied by the C |
| 672 | syntax for function declarations.")) |
| 673 | |
| 674 | (defmethod shared-initialize :after |
| 675 | ((type c-function-type) slot-names &key (arguments nil argsp)) |
| 676 | (declare (ignore slot-names)) |
| 677 | (when argsp |
| 678 | (setf (slot-value type 'arguments) |
| 679 | (if (and arguments |
| 680 | (null (cdr arguments)) |
| 681 | (not (eq (car arguments) :ellipsis)) |
| 682 | (eq (argument-type (car arguments)) c-type-void)) |
| 683 | nil |
| 684 | arguments)))) |
| 685 | |
| 686 | (export '(c-keyword-function-type c-function-keywords)) |
| 687 | (defclass c-keyword-function-type (c-function-type) |
| 688 | ((keywords :initarg :keywords :type list |
| 689 | :reader c-function-keywords)) |
| 690 | (:documentation |
| 691 | "C function types for `functions' which take keyword arguments.")) |
| 692 | |
| 693 | (defmethod shared-initialize :after |
| 694 | ((type c-keyword-function-type) slot-names &key (keywords nil keysp)) |
| 695 | (declare (ignore slot-names)) |
| 696 | (when keysp |
| 697 | (setf (slot-value type 'keywords) |
| 698 | (fix-and-check-keyword-argument-list keywords)))) |
| 699 | |
| 700 | ;; Constructor function. |
| 701 | |
| 702 | (export 'make-function-type) |
| 703 | (defun make-function-type (subtype arguments) |
| 704 | "Return a new function type, returning SUBTYPE and accepting ARGUMENTS. |
| 705 | |
| 706 | As a helper for dealing with the S-expression syntax for keyword |
| 707 | functions, if ARGUMENTS has the form (ARGS ... :keys KEYWORDS ...)' then |
| 708 | return a keyword function with arguments (ARGS ...) and keywords (KEYWORDS |
| 709 | ...)." |
| 710 | (let ((split (member :keys arguments))) |
| 711 | (if split |
| 712 | (make-instance 'c-keyword-function-type |
| 713 | :subtype subtype |
| 714 | :arguments (ldiff arguments split) |
| 715 | :keywords (cdr split)) |
| 716 | (make-instance 'c-function-type |
| 717 | :subtype subtype |
| 718 | :arguments arguments)))) |
| 719 | |
| 720 | (export 'make-keyword-function-type) |
| 721 | (defun make-keyword-function-type (subtype arguments keywords) |
| 722 | "Return a new keyword-function type, returning SUBTYPE and accepting |
| 723 | ARGUMENTS and KEYWORDS." |
| 724 | (make-instance 'c-keyword-function-type :subtype subtype |
| 725 | :arguments arguments :keywords keywords)) |
| 726 | |
| 727 | ;; Comparison protocol. |
| 728 | |
| 729 | (defmethod c-type-equal-p and |
| 730 | ((type-a c-function-type) (type-b c-function-type)) |
| 731 | (and (c-type-equal-p (c-type-subtype type-a) (c-type-subtype type-b)) |
| 732 | (argument-lists-equal-p (c-function-arguments type-a) |
| 733 | (c-function-arguments type-b)))) |
| 734 | |
| 735 | (defmethod c-type-equal-p and |
| 736 | ((type-a c-keyword-function-type) (type-b c-keyword-function-type)) |
| 737 | ;; Actually, there's nothing to check here. I'm happy as long as both |
| 738 | ;; functions notionally accept keyword arguments. |
| 739 | t) |
| 740 | |
| 741 | ;; C syntax output protocol. |
| 742 | |
| 743 | (export 'pprint-c-function-type) |
| 744 | (defun pprint-c-function-type (return-type stream print-args print-kernel) |
| 745 | "Common top-level printing for function types. |
| 746 | |
| 747 | Prints RETURN-TYPE (KERNEL(ARGS)), where RETURN-TYPE is the actual return |
| 748 | type, and ARGS and KERNEL are whatever is printed by the PRINT-ARGS and |
| 749 | PRINT-KERNEL functions. |
| 750 | |
| 751 | The PRINT-KERNEL function is the standard such thing for the |
| 752 | `pprint-c-type' protocol; PRINT-ARGS accepts just an output stream." |
| 753 | (pprint-c-type return-type stream |
| 754 | (lambda (stream prio spacep) |
| 755 | (maybe-in-parens (stream (> prio 2)) |
| 756 | (when spacep (c-type-space stream)) |
| 757 | (funcall print-kernel stream 2 nil) |
| 758 | (pprint-indent :block 4 stream) |
| 759 | (pprint-newline :linear stream) |
| 760 | (pprint-logical-block |
| 761 | (stream nil :prefix "(" :suffix ")") |
| 762 | (funcall print-args stream)))))) |
| 763 | |
| 764 | (export 'pprint-argument-list) |
| 765 | (defun pprint-argument-list (args stream) |
| 766 | "Print an argument list. |
| 767 | |
| 768 | The ARGS is a list of `argument' objects, optionally containing an |
| 769 | `:ellipsis' marker. The output is written to STREAM. |
| 770 | |
| 771 | Returns non-nil if any arguments were actually printed." |
| 772 | (let ((anyp nil)) |
| 773 | (pprint-logical-block (stream nil) |
| 774 | (dolist (arg args) |
| 775 | (if anyp |
| 776 | (format stream ", ~_") |
| 777 | (setf anyp t)) |
| 778 | (etypecase arg |
| 779 | ((member :ellipsis) |
| 780 | (write-string "..." stream)) |
| 781 | (argument |
| 782 | (pprint-logical-block (stream nil) |
| 783 | (pprint-c-type (argument-type arg) stream (argument-name arg)) |
| 784 | (let ((default (argument-default arg))) |
| 785 | (when default |
| 786 | (format stream " = ~2I~_~A" default)))))))) |
| 787 | anyp)) |
| 788 | |
| 789 | (let ((void-arglist (list (make-argument nil c-type-void)))) |
| 790 | (defmethod pprint-c-type ((type c-function-type) stream kernel) |
| 791 | (let ((args (or (c-function-arguments type) void-arglist))) |
| 792 | (pprint-c-function-type (c-type-subtype type) stream |
| 793 | (lambda (stream) |
| 794 | (pprint-argument-list args stream)) |
| 795 | kernel)))) |
| 796 | |
| 797 | (defmethod pprint-c-type ((type c-keyword-function-type) stream kernel) |
| 798 | (let ((args (c-function-arguments type)) |
| 799 | (keys (c-function-keywords type))) |
| 800 | (pprint-c-function-type (c-type-subtype type) stream |
| 801 | (lambda (stream) |
| 802 | (when (pprint-argument-list args stream) |
| 803 | (format stream ", ~_")) |
| 804 | (write-char #\? stream) |
| 805 | (pprint-argument-list keys stream)) |
| 806 | kernel))) |
| 807 | |
| 808 | ;; S-expression notation protocol. |
| 809 | |
| 810 | (defmethod print-c-type |
| 811 | (stream (type c-function-type) &optional colon atsign) |
| 812 | (declare (ignore colon atsign)) |
| 813 | (format stream "~:@<~ |
| 814 | FUN ~@_~:I~ |
| 815 | ~/sod:print-c-type/~:[~; ~]~:*~_~ |
| 816 | ~<~@{~:<~S ~@_~/sod:print-c-type/~:>~^ ~_~}~:>~ |
| 817 | ~:[~2*~; ~_~S ~@_~<~@{~:<~S ~@_~/sod:print-c-type/~ |
| 818 | ~@[ ~@_~S~]~:>~^ ~_~}~:>~]~ |
| 819 | ~:>" |
| 820 | (c-type-subtype type) |
| 821 | (mapcar (lambda (arg) |
| 822 | (if (eq arg :ellipsis) arg |
| 823 | (list (argument-name arg) (argument-type arg)))) |
| 824 | (c-function-arguments type)) |
| 825 | (typep type 'c-keyword-function-type) |
| 826 | :keys |
| 827 | (and (typep type 'c-keyword-function-type) |
| 828 | (mapcar (lambda (arg) |
| 829 | (list (argument-name arg) |
| 830 | (argument-type arg) |
| 831 | (argument-default arg))) |
| 832 | (c-function-keywords type))))) |
| 833 | |
| 834 | (export '(fun function () func fn)) |
| 835 | (define-c-type-syntax fun (ret &rest args) |
| 836 | "Return the type of functions which returns RET and has arguments ARGS. |
| 837 | |
| 838 | The ARGS are a list of arguments of the form (NAME TYPE [DEFAULT]). The |
| 839 | NAME can be NIL to indicate that no name was given. |
| 840 | |
| 841 | If an entry isn't a list, it's assumed to be the start of a Lisp |
| 842 | expression to compute the tail of the list; similarly, if the list is |
| 843 | improper, then it's considered to be a complete expression. The upshot of |
| 844 | this apparently bizarre rule is that you can say |
| 845 | |
| 846 | (c-type (fun int (\"foo\" int) . arg-tail)) |
| 847 | |
| 848 | where ARG-TAIL is (almost) any old Lisp expression and have it tack the |
| 849 | arguments onto the end. Of course, there don't have to be any explicit |
| 850 | arguments at all. The only restriction is that the head of the Lisp form |
| 851 | can't be a list -- so ((lambda (...) ...) ...) is out, but you probably |
| 852 | wouldn't type that anyway." |
| 853 | |
| 854 | `(make-function-type ,(expand-c-type-spec ret) |
| 855 | ,(do ((args args (cdr args)) |
| 856 | (list nil |
| 857 | (if (keywordp (car args)) |
| 858 | (cons (car args) list) |
| 859 | (let* ((name (caar args)) |
| 860 | (type (expand-c-type-spec |
| 861 | (cadar args))) |
| 862 | (default (and (cddar args) |
| 863 | (caddar args))) |
| 864 | (arg `(make-argument |
| 865 | ,name ,type ,default))) |
| 866 | (cons arg list))))) |
| 867 | ((or (atom args) |
| 868 | (and (atom (car args)) |
| 869 | (not (keywordp (car args))))) |
| 870 | (cond ((and (null args) (null list)) `nil) |
| 871 | ((null args) `(list ,@(nreverse list))) |
| 872 | ((null list) `,args) |
| 873 | (t `(list* ,@(nreverse list) ,args))))))) |
| 874 | (c-type-alias fun function () func fn) |
| 875 | |
| 876 | ;; Additional utilities for dealing with functions. |
| 877 | |
| 878 | (export 'commentify-argument-names) |
| 879 | (defun commentify-argument-names (arguments) |
| 880 | "Return an argument list with the arguments commentified. |
| 881 | |
| 882 | That is, with each argument name passed through |
| 883 | `commentify-argument-name'." |
| 884 | (mapcar (lambda (arg) |
| 885 | (if (eq arg :ellipsis) arg |
| 886 | (make-argument (commentify-argument-name (argument-name arg)) |
| 887 | (argument-type arg) |
| 888 | (argument-default arg)))) |
| 889 | arguments)) |
| 890 | |
| 891 | (export 'commentify-function-type) |
| 892 | (defun commentify-function-type (type) |
| 893 | "Return a type like TYPE, but with arguments commentified. |
| 894 | |
| 895 | This doesn't recurse into the return type or argument types." |
| 896 | (make-function-type (c-type-subtype type) |
| 897 | (commentify-argument-names |
| 898 | (c-function-arguments type)))) |
| 899 | |
| 900 | (export 'reify-variable-argument-tail) |
| 901 | (defun reify-variable-argument-tail (arguments) |
| 902 | "Replace any `:ellipsis' item in ARGUMENTS with a `va_list' argument. |
| 903 | |
| 904 | The argument's name is taken from the variable `*sod-ap*'." |
| 905 | (substitute (make-argument *sod-ap* c-type-va-list) :ellipsis arguments)) |
| 906 | |
| 907 | ;;;----- That's all, folks -------------------------------------------------- |