mdw@git.distorted.org.uk Git - sod/blob - c-types.lisp

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; Dealing with C types
   4 ;;;
   5 ;;; (c) 2008 Straylight/Edgeware
   6 ;;;
   7
   8 ;;;----- Licensing notice ---------------------------------------------------
   9 ;;;
  10 ;;; This file is part of the Simple Object Definition system.
  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 ;;; Plain old C types.
  30
  31 ;; Class definition.
  32
  33 (defclass c-type ()
  34   ()
  35   (:documentation
  36    "Base class for C type objects."))
  37
  38 ;; Important protocol.
  39
  40 (defgeneric c-declaration (type decl)
  41   (:documentation
  42    "Computes a declaration for a C type.
  43
  44    Returns two strings, a type and a declarator, suitable for declaring an
  45    object with the inner declarator DECL."))
  46
  47 (defgeneric c-type-subtype (type)
  48   (:documentation
  49    "For compound types, return the base type."))
  50
  51 (defgeneric c-type-equal-p (type-a type-b)
  52   (:method-combination and)
  53   (:documentation
  54    "Answers whether two types TYPE-A and TYPE-B are, in fact, equal.")
  55   (:method and (type-a type-b)
  56     (eql (class-of type-a) (class-of type-b))))
  57
  58 (defgeneric c-declarator-priority (type)
  59   (:documentation
  60    "Returns the priority for the declarator of TYPE.
  61
  62    Used to decide when to insert parentheses into the C representation.")
  63
  64   (:method ((type c-type))
  65     0))
  66
  67 (defgeneric print-c-type (stream type &optional colon atsign)
  68   (:documentation
  69    "Print an abbreviated syntax for TYPE to the STREAM."))
  70
  71 (defmethod print-object ((object c-type) stream)
  72   (if *print-escape*
  73       (format stream "~:@<C-TYPE ~/sod::print-c-type/~:>" object)
  74       (multiple-value-bind (base decl) (c-declaration object "")
  75         (format stream "~A~:[~; ~A~]" base (plusp (length decl)) decl))))
  76
  77 ;; Utility functions.
  78
  79 (defun maybe-parenthesize (decl me him)
  80   "Wrap parens around DECL, maybe, according to priorities of ME and HIM.
  81
  82    If the declarator for HIM has a higher priority than that of ME (as C
  83    types) then return DECL with parens wrapped around it; otherwise just
  84    return DECL."
  85   (if (<= (c-declarator-priority him)
  86           (c-declarator-priority me))
  87       decl
  88       (format nil "(~A)" decl)))
  89
  90 (defun compound-type-declaration (type format-control &rest format-args)
  91   "Convenience function for implementating compound types.
  92
  93    The declaration is formed from the type's subtype and by processing the
  94    given format string."
  95   (let ((subty (c-type-subtype type))
  96         (subdecl (format nil "~?" format-control format-args)))
  97     (c-declaration subty (maybe-parenthesize subdecl type subty))))
  98
  99 ;; S-expression syntax machinery.
 100
 101 (defun c-name-case (name)
 102   "Convert NAME to suitable case.
 103
 104    Strings are returned as-is; symbols are squashed to lower-case and hyphens
 105    are replaced by underscores."
 106   (typecase name
 107     (symbol (with-output-to-string (out)
 108               (loop for ch across (symbol-name name)
 109                     do (cond ((alpha-char-p ch)
 110                               (write-char (char-downcase ch) out))
 111                              ((or (digit-char-p ch)
 112                                   (char= ch #\_))
 113                               (write-char ch out))
 114                              ((char= ch #\-)
 115                               (write-char #\_ out))
 116                              (t
 117                               (error "Bad character in C name ~S." name))))))
 118     (t name)))
 119
 120 (defun expand-c-type (spec)
 121   "Parse SPEC as a C type and return the result.
 122
 123    The SPEC can be one of the following.
 124
 125      * A C-TYPE object, which is returned immediately.
 126
 127      * A list, (OPERATOR . ARGUMENTS), where OPERATOR is a symbol: a parser
 128        function associated with the OPERATOR symbol by DEFINE-C-TYPE-SYNTAX
 129        or some other means is invoked on the ARGUMENTS, and the result is
 130        returned.
 131
 132      * A symbol, which is treated the same way as a singleton list would be."
 133
 134   (flet ((interp (sym)
 135            (or (get sym 'c-type)
 136                (error "Unknown C type operator ~S." sym))))
 137     (etypecase spec
 138       (c-type spec)
 139       (symbol (funcall (interp spec)))
 140       (list (apply (interp (car spec)) (cdr spec))))))
 141
 142 (defmacro c-type (spec)
 143   "Evaluates to the type that EXPAND-C-TYPE would return.
 144
 145    Currently this just quotes SPEC and calls EXPAND-C-TYPE at runtime.  Maybe
 146    later it will do something more clever."
 147   `(expand-c-type ',spec))
 148
 149 (defmacro define-c-type-syntax (name bvl &rest body)
 150   "Define a C-type syntax function.
 151
 152    A function defined by BODY and with lambda-list BVL is associated with the
 153    NAME.  When EXPAND-C-TYPE sees a list (NAME . STUFF), it will call this
 154    function with the argument list STUFF."
 155   `(progn
 156      (setf (get ',name 'c-type) (lambda ,bvl ,@body))
 157      ',name))
 158
 159 (defmacro c-type-alias (original &rest aliases)
 160   "Make ALIASES behave the same way as the ORIGINAL type."
 161   (let ((i (gensym)) (orig (gensym)))
 162     `(let ((,orig (get ',original 'c-type)))
 163        (dolist (,i ',aliases)
 164          (setf (get ,i 'c-type) ,orig)))))
 165
 166 (defmacro defctype (names value)
 167   "Define NAMES all to describe the C-type VALUE.
 168
 169    NAMES can be a symbol (treated as a singleton list), or a list of symbols.
 170    The VALUE is a C type S-expression, acceptable to EXPAND-C-TYPE.  It will
 171    be expanded once at run-time."
 172   (unless (listp names)
 173     (setf names (list names)))
 174   (let ((ty (gensym)))
 175     `(let ((,ty (expand-c-type ',value)))
 176        (setf (get ',(car names) 'c-type) (lambda () ,ty))
 177        ,@(and (cdr names)
 178               `((c-type-alias ,(car names) ,@(cdr names)))))))
 179
 180 ;;;--------------------------------------------------------------------------
 181 ;;; Types which can accept qualifiers.
 182
 183 ;; Basic definitions.
 184
 185 (defclass qualifiable-c-type (c-type)
 186   ((qualifiers :initarg :qualifiers
 187                :type list
 188                :initform nil
 189                :accessor c-type-qualifiers))
 190   (:documentation
 191    "Base class for C types which can be qualified."))
 192
 193 (defun format-qualifiers (quals)
 194   "Return a string listing QUALS, with a space after each."
 195   (format nil "~{~(~A~) ~}" quals))
 196
 197 (defmethod c-type-equal-p and ((type-a qualifiable-c-type)
 198                                (type-b qualifiable-c-type))
 199   (flet ((fix (type)
 200            (sort (copy-list (c-type-qualifiers type)) #'string<)))
 201     (equal (fix type-a) (fix type-b))))
 202
 203 (defmethod print-c-type :around
 204     (stream (type qualifiable-c-type) &optional colon atsign)
 205   (if (c-type-qualifiers type)
 206       (pprint-logical-block (stream nil :prefix "(" :suffix ")")
 207         (format stream "QUALIFIER~{ ~:_~:I~A~} ~:_"
 208                 (c-type-qualifiers type))
 209         (call-next-method stream type colon atsign))
 210       (call-next-method)))
 211
 212 ;; A handy utility.
 213
 214 (let ((cache (make-hash-table :test #'equal)))
 215   (defun qualify-type (c-type qualifiers)
 216     "Returns a qualified version of C-TYPE.
 217
 218    Maintains a cache of qualified types so that we don't have to run out of
 219    memory.  This can also speed up type comparisons."
 220     (if (null qualifiers)
 221         c-type
 222         (let ((key (cons c-type qualifiers)))
 223           (unless (typep c-type 'qualifiable-c-type)
 224             (error "~A isn't qualifiable." (class-name (class-of c-type))))
 225           (or (gethash key cache)
 226               (setf (gethash key cache)
 227                     (copy-instance c-type :qualifiers qualifiers)))))))
 228
 229 ;; S-expression machinery.  Qualifiers have hairy syntax and need to be
 230 ;; implemented by hand.
 231
 232 (defun qualifier (qual &rest args)
 233   "Parse a qualified C type.
 234
 235    The ARGS consist of a number of qualifiers and exactly one C-type
 236    S-expression.  The result is a qualified version of this type, with the
 237    given qualifiers attached."
 238   (if (null args)
 239       qual
 240       (let* ((things (mapcar #'expand-c-type args))
 241              (quals (delete-duplicates
 242                      (sort (cons qual (remove-if-not #'keywordp things))
 243                            #'string<)))
 244              (types (remove-if-not (lambda (thing) (typep thing 'c-type))
 245                                    things)))
 246         (when (or (null types)
 247                   (not (null (cdr types))))
 248           (error "Only one proper type expected in ~S." args))
 249         (qualify-type (car types) quals))))
 250 (setf (get 'qualifier 'c-type) #'qualifier)
 251
 252 (defun declare-qualifier (qual)
 253   "Defines QUAL as being a type qualifier.
 254
 255    When used as a C-type operator, it applies that qualifier to the type that
 256    is its argument."
 257   (let ((kw (intern (string qual) :keyword)))
 258     (setf (get qual 'c-type)
 259           (lambda (&rest args)
 260             (apply #'qualifier kw args)))))
 261
 262 ;; Define some initial qualifiers.
 263 (dolist (qual '(const volatile restrict))
 264   (declare-qualifier qual))
 265
 266 ;;;--------------------------------------------------------------------------
 267 ;;; Simple C types (e.g., built-in arithmetic types).
 268
 269 (defvar *simple-type-map* (make-hash-table :test #'equal)
 270   "A hash table mapping type strings to Lisp symbols naming them.")
 271
 272 ;; Basic definitions.
 273
 274 (defclass simple-c-type (qualifiable-c-type)
 275   ((name :initarg :name
 276          :type string
 277          :reader c-type-name))
 278   (:documentation
 279    "C types with simple forms."))
 280
 281 (let ((cache (make-hash-table :test #'equal)))
 282   (defun make-simple-type (name)
 283     "Make a distinguished object for the simple type called NAME."
 284     (or (gethash name cache)
 285         (setf (gethash name cache)
 286               (make-instance 'simple-c-type :name name)))))
 287
 288 (defmethod c-declaration ((type simple-c-type) decl)
 289   (values (concatenate 'string
 290                        (format-qualifiers (c-type-qualifiers type))
 291                        (c-type-name type))
 292           decl))
 293
 294 (defmethod c-type-equal-p and ((type-a simple-c-type)
 295                                (type-b simple-c-type))
 296   (string= (c-type-name type-a) (c-type-name type-b)))
 297
 298 (defmethod print-c-type (stream (type simple-c-type) &optional colon atsign)
 299   (declare (ignore colon atsign))
 300   (let* ((name (c-type-name type))
 301          (symbol (gethash name *simple-type-map*)))
 302     (if symbol
 303         (princ symbol stream)
 304         (format stream "~:@<SIMPLE-C-TYPE ~@_~S~:>" name))))
 305
 306 ;; S-expression syntax.
 307
 308 (define-c-type-syntax simple-c-type (name)
 309   "Constructs a simple C type called NAME (a string or symbol)."
 310   (make-simple-type (c-name-case name)))
 311
 312 (defmacro define-simple-c-type (names type)
 313   "Define each of NAMES to be a simple type called TYPE."
 314   `(progn
 315      (setf (gethash ,type *simple-type-map*)
 316            ',(if (listp names) (car names) names))
 317      (defctype ,names (simple-c-type ,type))))
 318
 319 (define-simple-c-type void "void")
 320
 321 (define-simple-c-type char "char")
 322 (define-simple-c-type (unsigned-char uchar) "unsigned char")
 323 (define-simple-c-type (signed-char schar) "signed char")
 324
 325 (define-simple-c-type (int signed signed-int sint) "int")
 326 (define-simple-c-type (unsigned unsigned-int uint) "unsigned")
 327
 328 (define-simple-c-type (short signed-short short-int signed-short-int sshort)
 329   "short")
 330 (define-simple-c-type (unsigned-short unsigned-short-int ushort)
 331   "unsigned short")
 332
 333 (define-simple-c-type (long signed-long long-int signed-long-int slong)
 334   "long")
 335 (define-simple-c-type (unsigned-long unsigned-long-int ulong)
 336   "unsigned long")
 337
 338 (define-simple-c-type (long-long signed-long-long long-long-int
 339                        signed-long-long-int llong sllong)
 340   "long long")
 341 (define-simple-c-type (unsigned-long-long unsigned-long-long-int ullong)
 342   "unsigned long long")
 343
 344 (define-simple-c-type float "float")
 345 (define-simple-c-type double "double")
 346 (define-simple-c-type long-double "long double")
 347
 348 (define-simple-c-type va-list "va_list")
 349 (define-simple-c-type size-t "size_t")
 350 (define-simple-c-type ptrdiff-t "ptrdiff_t")
 351
 352 ;;;--------------------------------------------------------------------------
 353 ;;; Tag types (structs, unions and enums).
 354
 355 ;; Definitions.
 356
 357 (defclass tagged-c-type (qualifiable-c-type)
 358   ((tag :initarg :tag
 359         :type string
 360         :reader c-type-tag))
 361   (:documentation
 362    "C types with tags."))
 363
 364 (defgeneric c-tagged-type-kind (type)
 365   (:documentation
 366    "Return the kind of tagged type that TYPE is, as a keyword."))
 367
 368 (macrolet ((define-tagged-type (kind what)
 369              (let ((type (intern (format nil "C-~A-TYPE" (string kind))))
 370                    (constructor (intern (format nil "MAKE-~A-TYPE"
 371                                                 (string kind)))))
 372                `(progn
 373                   (defclass ,type (tagged-c-type) ()
 374                     (:documentation ,(format nil "C ~a types." what)))
 375                   (defmethod c-tagged-type-kind ((type ,type))
 376                     ,kind)
 377                   (let ((cache (make-hash-table :test #'equal)))
 378                     (defun ,constructor (tag)
 379                       (or (gethash tag cache)
 380                           (setf (gethash tag cache)
 381                                 (make-instance ',type :tag tag)))))
 382                     (define-c-type-syntax ,(intern (string kind)) (tag)
 383                       ,(format nil "Construct ~A type named TAG" what)
 384                       (,constructor tag))))))
 385   (define-tagged-type :enum "enumerated")
 386   (define-tagged-type :struct "structure")
 387   (define-tagged-type :union "union"))
 388
 389 (defclass c-enum-type (tagged-c-type)
 390   ()
 391   (:documentation
 392    "C enumeration types."))
 393 (defclass c-struct-type (tagged-c-type)
 394   ()
 395   (:documentation
 396    "C structure types."))
 397 (defclass c-union-type (tagged-c-type)
 398   ()
 399   (:documentation
 400    "C union types."))
 401
 402 (defmethod c-declaration ((type tagged-c-type) decl)
 403   (values (concatenate 'string
 404                        (format-qualifiers (c-type-qualifiers type))
 405                        (string-downcase (c-tagged-type-kind type))
 406                        " "
 407                        (c-type-tag type))
 408           decl))
 409
 410 (defmethod c-type-equal-p and ((type-a tagged-c-type)
 411                                (type-b tagged-c-type))
 412   (string= (c-type-tag type-a) (c-type-tag type-b)))
 413
 414 (defmethod print-c-type (stream (type tagged-c-type) &optional colon atsign)
 415   (declare (ignore colon atsign))
 416   (format stream "~:@<~A ~A~:>"
 417           (c-tagged-type-kind type)
 418           (c-type-tag type)))
 419
 420 ;; S-expression syntax.
 421
 422 (define-c-type-syntax enum (tag)
 423   "Construct an enumeration type named TAG."
 424   (make-instance 'c-enum-type :tag (c-name-case tag)))
 425 (define-c-type-syntax struct (tag)
 426   "Construct a structure type named TAG."
 427   (make-instance 'c-struct-type :tag (c-name-case tag)))
 428 (define-c-type-syntax union (tag)
 429   "Construct a union type named TAG."
 430   (make-instance 'c-union-type :tag (c-name-case tag)))
 431
 432 ;;;--------------------------------------------------------------------------
 433 ;;; Pointer types.
 434
 435 ;; Definitions.
 436
 437 (defclass c-pointer-type (qualifiable-c-type)
 438   ((subtype :initarg :subtype
 439             :type c-type
 440             :reader c-type-subtype))
 441   (:documentation
 442    "C pointer types."))
 443
 444 (defmethod c-declarator-priority ((type c-pointer-type)) 1)
 445
 446 (defmethod c-declaration ((type c-pointer-type) decl)
 447   (compound-type-declaration type
 448                              "*~A~A"
 449                              (format-qualifiers (c-type-qualifiers type))
 450                              decl))
 451
 452 (defmethod c-type-equal-p and ((type-a c-pointer-type)
 453                                (type-b c-pointer-type))
 454   (c-type-equal-p (c-type-subtype type-a)
 455                   (c-type-subtype type-b)))
 456
 457 (defmethod print-c-type (stream (type c-pointer-type) &optional colon atsign)
 458   (declare (ignore colon atsign))
 459   (format stream "~:@<* ~@_~/sod::print-c-type/~:>"
 460           (c-type-subtype type)))
 461
 462 ;; S-expression syntax.
 463
 464 (define-c-type-syntax pointer (sub)
 465   "Return the type of pointer-to-SUB."
 466   (make-instance 'c-pointer-type :subtype (expand-c-type sub)))
 467 (c-type-alias pointer * ptr)
 468
 469 (defctype string (* char))
 470
 471 ;;;--------------------------------------------------------------------------
 472 ;;; Array types.
 473
 474 ;; Definitions.
 475
 476 (defclass c-array-type (c-type)
 477   ((subtype :initarg :subtype
 478             :type c-type
 479             :reader c-type-subtype)
 480    (dimensions :initarg :dimensions
 481                :type list
 482                :reader c-array-dimensions))
 483   (:documentation
 484    "C array types."))
 485
 486 (defmethod c-declarator-priority ((type c-array-type)) 2)
 487
 488 (defmethod c-declaration ((type c-array-type) decl)
 489   (compound-type-declaration type
 490                              "~A~{[~@[~A~]]~}"
 491                              decl
 492                              (c-array-dimensions type)))
 493
 494 (defmethod c-type-equal-p and ((type-a c-array-type)
 495                                (type-b c-array-type))
 496   (and (c-type-equal-p (c-type-subtype type-a)
 497                        (c-type-subtype type-b))
 498        (equal (c-array-dimensions type-a)
 499               (c-array-dimensions type-b))))
 500
 501 (defmethod print-c-type (stream (type c-array-type) &optional colon atsign)
 502   (declare (ignore colon atsign))
 503   (format stream "~:@<[] ~@_~:I~/sod::print-c-type/~{ ~_~A~}~:>"
 504           (c-type-subtype type)
 505           (c-array-dimensions type)))
 506
 507 ;; S-expression syntax.
 508
 509 (define-c-type-syntax array (sub &rest dims)
 510   "Return the type of arrays of SUB with the dimensions DIMS.
 511
 512    If the DIMS are omitted, a single unknown-length dimension is added."
 513   (make-instance 'c-array-type
 514                  :subtype (expand-c-type sub)
 515                  :dimensions (or dims '(nil))))
 516 (c-type-alias array [] vec)
 517
 518 ;;;--------------------------------------------------------------------------
 519 ;;; Function types.
 520
 521 ;; Definitions.
 522
 523 (defclass c-function-type (c-type)
 524   ((subtype :initarg :subtype
 525             :type c-type
 526             :reader c-type-subtype)
 527    (arguments :initarg :arguments
 528               :type list
 529               :reader c-function-arguments))
 530   (:documentation
 531    "C function types.  The subtype is the return type, as implied by the C
 532     syntax for function declarations."))
 533
 534 (defmethod c-declarator-priority ((type c-function-type)) 2)
 535
 536 (defstruct (argument (:constructor make-argument (name type)) (:type list))
 537   "Simple list structure representing a function argument."
 538   name
 539   type)
 540
 541 (defmethod c-declaration ((type c-function-type) decl)
 542   (compound-type-declaration type
 543                              "~A(~:[void~;~:*~{~A~^, ~}~])"
 544                              decl
 545                              (mapcar (lambda (arg)
 546                                        (if (eq arg :ellipsis)
 547                                            "..."
 548                                            (multiple-value-bind
 549                                                (typestr declstr)
 550                                                (c-declaration
 551                                                 (argument-type arg)
 552                                                 (or (argument-name arg) ""))
 553                                              (format nil "~A~:[~; ~A~]"
 554                                                      typestr
 555                                                      (plusp (length declstr))
 556                                                      declstr))))
 557                                      (c-function-arguments type))))
 558
 559 (defun arguments-lists-equal-p (list-a list-b)
 560   (and (= (length list-a) (length list-b))
 561        (every (lambda (arg-a arg-b)
 562                 (if (eq arg-a :ellipsis)
 563                     (eq arg-b :ellipsis)
 564                     (c-type-equal-p (argument-type arg-a)
 565                                     (argument-type arg-b))))
 566               list-a list-b)))
 567
 568 (defmethod c-type-equal-p and ((type-a c-function-type)
 569                                (type-b c-function-type))
 570   (and (c-type-equal-p (c-type-subtype type-a)
 571                        (c-type-subtype type-b))
 572        (arguments-lists-equal-p (c-function-arguments type-a)
 573                                 (c-function-arguments type-b))))
 574
 575 (defmethod print-c-type
 576     (stream (type c-function-type) &optional colon atsign)
 577   (declare (ignore colon atsign))
 578   (format stream
 579           #.(concatenate 'string
 580                          "~:@<"
 581                          "FUN ~@_~:I~/sod::print-c-type/"
 582                          "~{ ~_~:<~A ~@_~/sod::print-c-type/~:>~}"
 583                          "~:>")
 584           (c-type-subtype type)
 585           (c-function-arguments type)))
 586
 587 ;; S-expression syntax.
 588
 589 (define-c-type-syntax function (ret &rest args)
 590   "Return the type of functions which returns RET and has arguments ARGS.
 591
 592    The ARGS are a list (NAME TYPE).  The NAME can be NIL to indicate that no
 593    name was given."
 594   (make-instance 'c-function-type
 595                  :subtype (expand-c-type ret)
 596                  :arguments (mapcar (lambda (arg)
 597                                       (make-argument (car arg)
 598                                                      (expand-c-type
 599                                                       (cadr arg))))
 600                                     args)))
 601 (c-type-alias function () func fun fn)
 602
 603 ;;;----- That's all, folks --------------------------------------------------