src/c-types-{proto,impl,parse}.lisp: Add `storage specifiers' to the model.

[sod] / src / c-types-parse.lisp

diff --git a/src/c-types-parse.lisp b/src/c-types-parse.lisp
index 92f999a..94e8687 100644 (file)
--- a/src/c-types-parse.lisp
+++ b/src/c-types-parse.lisp
@@ -70,7 +70,7 @@
   ;; accessor functions later.
   ((label :type keyword :initarg :label :reader ds-label)
    (name :type string :initarg :name :reader ds-name)
-   (kind :type (member type complexity sign size qualifier)
+   (kind :type (member type complexity sign size qualifier specs)
         :initarg :kind :reader ds-kind)
    (taggedp :type boolean :initarg :taggedp
            :initform nil :reader ds-taggedp))
@@ -120,6 +120,13 @@
     map)
   "Maps symbolic labels and textual names to `declspec' instances.")
 
+(defclass storespec ()
+  ((spec :initarg :spec :reader ds-spec))
+  (:documentation "Carrier for a storage specifier."))
+
+(defmethod ds-label ((spec storespec)) spec)
+(defmethod ds-kind ((spec storespec)) 'specs)
+
 (defmethod ds-label ((ty c-type)) :c-type)
 (defmethod ds-name ((ty c-type)) (princ-to-string ty))
 (defmethod ds-kind ((ty c-type)) 'type)
@@ -133,6 +140,7 @@
    (complexity :initform nil :initarg :complexity :reader ds-complexity)
    (sign :initform nil :initarg :sign :reader ds-sign)
    (size :initform nil :initarg :size :reader ds-size)
+   (specs :initform nil :initarg :specs :reader ds-specs)
    (qualifier :initform nil :initarg :qualifiers :reader ds-qualifiers))
   (:documentation "Represents a collection of declaration specifiers.
 
@@ -187,6 +195,7 @@
                      ((and (eq (ds-label old) :long) (eq ds old))
                       (values t (gethash :long-long *declspec-map*)))
                      (t (values nil nil))))
+         (specs (values t (adjoin (ds-spec ds) old)))
          (t (values (not old) ds)))
       (if ok
          (let ((copy (copy-instance specs)))
@@ -196,30 +205,34 @@
 
 (defun declspecs-type (specs)
   "Convert `declspecs' SPECS into a standalone C type object."
-  (let ((type (ds-type specs))
-       (size (ds-size specs))
-       (sign (ds-sign specs))
-       (cplx (ds-complexity specs))
-       (quals (mapcar #'ds-label (ds-qualifiers specs))))
-    (cond ((typep type 'c-type)
-          (qualify-c-type type quals))
-         ((or type size sign cplx)
-          (when (and sign (eq (ds-label sign) :signed)
-                     (eq (ds-label type) :int))
-            (setf sign nil))
-          (cond ((and (or (null type) (eq (ds-label type) :int))
-                      (or size sign))
-                 (setf type nil))
-                ((null type)
-                 (setf type (gethash :int *declspec-map*))))
-          (make-simple-type (format nil "~{~@[~A~^ ~]~}"
-                                    (mapcar #'ds-name
-                                            (remove nil
-                                                    (list sign cplx
-                                                          size type))))
-                            quals))
-         (t
-          nil))))
+  (let* ((base-type (ds-type specs))
+        (size (ds-size specs))
+        (sign (ds-sign specs))
+        (cplx (ds-complexity specs))
+        (quals (mapcar #'ds-label (ds-qualifiers specs)))
+        (specs (ds-specs specs))
+        (type (cond ((typep base-type 'c-type)
+                     (qualify-c-type base-type quals))
+                    ((or base-type size sign cplx)
+                     (when (and sign (eq (ds-label sign) :signed)
+                                (eq (ds-label base-type) :int))
+                       (setf sign nil))
+                     (cond ((and (or (null base-type)
+                                     (eq (ds-label base-type) :int))
+                                 (or size sign))
+                            (setf base-type nil))
+                           ((null base-type)
+                            (setf base-type (gethash :int *declspec-map*))))
+                     (let* ((things (list sign cplx size base-type))
+                            (stripped (remove nil things))
+                            (names (mapcar #'ds-name stripped)))
+                       (make-simple-type (format nil "~{~A~^ ~}" names)
+                                         quals)))
+                    (t
+                     nil))))
+    (cond ((null type) nil)
+         ((null specs) type)
+         (t (make-storage-specifiers-type type specs)))))
 
 ;; Parsing declaration specifiers.
 
@@ -477,6 +490,9 @@
                              (or (postfix-lparen)
                                  (lbracket)
                                  (when nestedp (seq (#\)) (rparen #\))))))))
-                (cons (funcall (car value) base-type) (cdr value))))))))
+                (cons (wrap-c-type (lambda (type)
+                                     (funcall (car value) type))
+                                   base-type)
+                      (cdr value))))))))
 
 ;;;----- That's all, folks --------------------------------------------------