chiark - git - mdw - sod/blob - src/parse-c-types.lisp

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; Parser for C types
   4 ;;;
   5 ;;; (c) 2009 Straylight/Edgeware
   6 ;;;
   7
   8 ;;;----- Licensing notice ---------------------------------------------------
   9 ;;;
  10 ;;; This file is part of the Sensble 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 ;;; Declaration specifiers.
  30
  31 (defclass declspec ()
  32   ((label :type keyword :initarg :label :reader ds-label)
  33    (name :type string :initarg :name :reader ds-name)
  34    (kind :type (member type sign size qualifier tagged)
  35          :initarg :kind :reader ds-kind)))
  36
  37 (defmethod shared-initialize :after ((ds declspec) slot-names &key)
  38   (default-slot (ds 'name slot-names)
  39     (string-downcase (ds-label ds))))
  40
  41 (defclass declspecs ()
  42   ((type :initform nil :initarg :type :reader ds-type)
  43    (sign :initform nil :initarg :sign :reader ds-sign)
  44    (size :initform nil :initarg :size :reader ds-size)
  45    (qualifier :initform nil :initarg :qualifiers :reader ds-qualifiers)))
  46
  47 (defparameter *declspec-map*
  48   (let ((map (make-hash-table :test #'equal)))
  49     (dolist (item '((type :void :char :int :float :double)
  50                     (size :short :long (:long-long "long long"))
  51                     (sign :signed :unsigned)
  52                     (qualifier :const :restrict :volatile)
  53                     (tagged :enum :struct :union)))
  54       (let ((kind (car item)))
  55         (dolist (spec (cdr item))
  56           (multiple-value-bind (label name)
  57               (if (consp spec)
  58                   (values (car spec) (cadr spec))
  59                   (values spec (string-downcase spec)))
  60             (let ((ds (make-instance 'declspec
  61                                      :label label :name name :kind kind)))
  62               (setf (gethash name map) ds
  63                     (gethash label map) ds))))))
  64     map))
  65
  66 (defmethod ds-label ((ty c-type)) :c-type)
  67 (defmethod ds-name ((ty c-type)) (princ-to-string ty))
  68 (defmethod ds-kind ((ty c-type)) 'type)
  69
  70 (defparameter *good-declspecs*
  71   '(((:int) (:signed :unsigned) (:short :long :long-long))
  72     ((:char) (:signed :unsigned) ())
  73     ((:double) () (:long))
  74     (t () ()))
  75   "List of good collections of declaration specifiers.
  76
  77    Each item is a list of the form (TYPES SIGNS SIZES).  Each of TYPES, SIGNS
  78    and SIZES is either a list of acceptable specifiers of the appropriate
  79    kind, or T, which matches any specifier.")
  80
  81 (defun scan-declspec (scanner)
  82   "Scan a DECLSPEC from SCANNER.
  83
  84    Value on success is either a DECLSPEC object or a C-TYPE object."
  85
  86   ;; Turns out to be easier to do this by hand.
  87   (let ((ds (and (eq (token-type scanner) :id)
  88                  (let ((kw (token-value scanner)))
  89                    (or (gethash kw *declspec-map*)
  90                        (gethash kw *module-type-map*))))))
  91     (cond ((not ds)
  92            (values (list :declspec) nil nil))
  93           ((eq (ds-kind ds) :tagged)
  94            (scanner-step scanner)
  95            (if (eq (token-type scanner) :id)
  96                (let ((ty (make-c-tagged-type (ds-label ds)
  97                                              (token-value scanner))))
  98                  (scanner-step scanner)
  99                  (values ty t t))
 100                (values :tag nil t)))
 101           (t
 102            (scanner-step scanner)
 103            (values ds t t)))))
 104
 105 (defun good-declspecs-p (specs)
 106   "Are SPECS a good collection of declaration specifiers?"
 107   (let ((speclist (list (ds-type specs) (ds-sign specs) (ds-size specs))))
 108     (some (lambda (it)
 109             (every (lambda (spec pat)
 110                      (or (eq pat t) (null spec)
 111                          (member (ds-label spec) pat)))
 112                    speclist it))
 113           *good-declspecs*)))
 114
 115 (defun combine-declspec (specs ds)
 116   "Combine the declspec DS with the existing SPECS.
 117
 118    Returns new DECLSPECS if they're OK, or `nil' if not.  The old SPECS are
 119    not modified."
 120   (let* ((kind (ds-kind ds))
 121          (old (slot-value specs kind)))
 122     (multiple-value-bind (ok new)
 123         (case kind
 124           (qualifier (values t (adjoin ds old)))
 125           (size (cond ((not old) (values t ds))
 126                       ((and (eq (ds-label old) :long) (eq ds old))
 127                        (values t (gethash :long-long *declspec-map*)))
 128                       (t (values nil nil))))
 129           (t (values (not old) ds)))
 130       (if ok
 131           (let ((copy (copy-instance specs)))
 132             (setf (slot-value copy kind) new)
 133             (and (good-declspecs-p copy) copy))
 134           nil))))
 135
 136 (defun scan-and-merge-declspec (scanner specs)
 137   (with-parser-context (token-scanner-context :scanner scanner)
 138     (if-parse (:consumedp consumedp) (scan-declspec scanner)
 139       (aif (combine-declspec specs it)
 140            (values it t consumedp)
 141            (values (list :declspec) nil consumedp)))))
 142
 143 (defun declspecs-type (specs)
 144   (let ((type (ds-type specs))
 145         (size (ds-size specs))
 146         (sign (ds-sign specs)))
 147     (cond ((or type size sign)
 148            (when (and (eq (ds-label sign) :signed)
 149                       (eq (ds-label type) :int))
 150              (setf sign nil))
 151            (cond ((and (or (null type) (eq (ds-label type) :int))
 152                        (or size sign))
 153                   (setf type nil))
 154                  ((null type)
 155                   (setf type (gethash :int *declspec-map*))))
 156            (make-simple-type (format nil "~{~@[~A~^ ~]~}"
 157                                      (mapcar #'ds-label
 158                                              (remove nil
 159                                                      (list sign size type))))
 160                              (mapcar #'ds-label (ds-qualifiers specs))))
 161           (t
 162            nil))))
 163
 164 (defun parse-c-type (scanner)
 165   (with-parser-context (token-scanner-context :scanner scanner)
 166     (if-parse (:result specs :consumedp cp)
 167               (many (specs (make-instance 'declspecs) it :min 1)
 168                 (scan-and-merge-declspec scanner specs))
 169               (let ((type (declspecs-type specs)))
 170                 (if type (values type t cp)
 171                     (values (list :declspec) nil cp))))))
 172
 173
 174
 175
 176
 177
 178
 179
 180
 181
 182
 183   ;; This is rather complicated, but extracting all the guts into a structure
 184   ;; and passing it around makes matters worse rather than better.
 185   ;;
 186   ;; We categorize declaration specifiers into four kinds.
 187   ;;
 188   ;;   * `Type specifiers' describe the actual type, whether that's integer,
 189   ;;     character, floating point, or some tagged or user-named type.
 190   ;;
 191   ;;   * `Size specifiers' distinguish different sizes of the same basic
 192   ;;     type.  This is how we tell the difference between `int' and `long'.
 193   ;;
 194   ;;   * `Sign specifiers' distinguish different signednesses.  This is how
 195   ;;     we tell the difference between `int' and `unsigned'.
 196   ;;
 197   ;;   * `Qualifiers' are our old friends `const', `restrict' and `volatile'.
 198   ;;
 199   ;; These groupings are for our benefit here, in determining whether a
 200   ;; particular declaration specifier is valid in the current context.  We
 201   ;; don't accept `function specifiers' (of which the only current example is
 202   ;; `inline') since it's meaningless to us.
 203   ;;
 204   ;; Our basic strategy is to parse declaration specifiers while they're
 205   ;; valid, and keep track of what we've read.  When we've reached the end,
 206   ;; we'll convert what we've got into a `canonical form', and then convert
 207   ;; that into a C type object of the appropriate kind.
 208
 209   (let ((specs (make-instance 'declspecs)))
 210
 211
 212   (let ((toks nil) (type nil) (size nil) (sign nil) (quals nil))
 213     (labels ((goodp (ty sg sz)
 214                "Are (TY SG SZ) a good set of declaration specifiers?"
 215                (some (lambda (it)
 216                        (every (lambda (spec pat)
 217                                 (or (eq pat t) (eq spec nil)
 218                                     (member spec pat)))
 219                               decls it))
 220                      *good-declspecs*))
 221
 222              (scan-declspec ()
 223                "Scan a declaration specifier."
 224                (flet ((win (value &optional (consumedp t))
 225                         (when consumedp (scanner-step scanner))
 226                         (return-from scan-declspec
 227                           (values value t consumedp)))
 228                       (lose (wanted &optional (consumedp nil))
 229                         (values wanted nil consumedp)))
 230                  (unless (eq (token-type scanner) :id) (lose :declspec))
 231                  (let* ((id (token-value scanner))
 232                         (ds (or (gethash id *declspec-map*)
 233                                 (gethash id *module-type-map*))))
 234                    (unless ds (lose :declspec))
 235                    (let ((label (ds-label ds)))
 236                      (ecase (ds-kind ds)
 237                        (:qualifier
 238                         (push (ds-label ds) quals)
 239                         (win ds))
 240                        (:size
 241                         (cond ((and (not size) (goodp type label sign))
 242                                (setf size label)
 243                                (win ds))
 244                               (t
 245                                (lose :declspec))))
 246                        (:sign
 247                         (cond ((and (not sign) (goodp type size label))
 248                                (setf sign label)
 249                                (win ds))
 250                               (t
 251                                (lose :declspec))))
 252                        (:type
 253                         (when (and (eq type :long) (eq label :long))
 254                           (setf label :long-long))
 255                         (cond ((and (or (not type) (eq type :long))
 256                                     (goodp label size sign))
 257                                (setf type label)
 258                                (win ds))
 259                               (t
 260                                (lose :declspec))))
 261                        (:tagged
 262                         (unless (and (not type) (goodp label size sign))
 263                           (lose :declspec))
 264                         (scanner-step scan)
 265                         (unless (eq (token-type scanner) :id)
 266                           (lose :tagged t))
 267                         (setf type
 268                               (make-c-tagged-type label
 269                                                   (token-value scanner)))
 270                         (win type))))))))
 271
 272       (with-parser-context (token-scanner-context :scanner scanner)
 273         (many (nil nil nil :min 1)
 274           (scan-declspec))
 275
 276
 277
 278
 279   (let ((toks nil) (type nil) (size nil) (sign nil) (quals nil))
 280     (labels ((check (ty sz sg)
 281                (case ty
 282                  ((nil :int) t)
 283                  (:char (null sz))
 284                  (:double (and (null sg) (or (null sz) (eq sz :long))))
 285                  (t (and (null sg) (null sz)))))
 286              (set-type (ty)
 287                (when ))
 288              (set-size (sz)
 289                (when (and (eq sz :long) (eq size :long))
 290                  (setf sz :long-long))
 291                (when (and (or (null size) (eq sz :long-long))
 292                           (check type sz sign))
 293                  (setf size sz)))
 294              (set-sign (sg)
 295                (when (and (null sign) (check type size sg))
 296                  (setf sign sg)))
 297              (parse-declspec ()
 298                (multiple-value-bind (kind value)
 299                    (categorize-declspec scanner)
 300                  (if (ecase kind
 301                        (:qualifier (push value quals))
 302                        (:type (and (null type) (check value size sign)
 303                                    (setf type value)))
 304                        (:size (let ((sz (if (and (eq size :long)
 305                                                  (eq value :long))
 306                                             :long-long value)))
 307                                 (and (or (null size) (eq sz :long-long))
 308                                      (check type value sign)
 309                                      (setf size value))))
 310                        (:sign (and (null sign) (check type size value)
 311                                    (setf sign value)))
 312
 313
 314 ;;;----- That's all, folks --------------------------------------------------