| 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 -------------------------------------------------- |