It lives!

[sod] / parse-c-types.lisp

diff --git a/parse-c-types.lisp b/parse-c-types.lisp
index 702ae77..63e8b9b 100644 (file)
--- a/parse-c-types.lisp
+++ b/parse-c-types.lisp
@@ -45,13 +45,49 @@
 ;;; groups the other three kinds together and calls them all `type
 ;;; specifiers' (6.7.2).
 
 ;;; groups the other three kinds together and calls them all `type
 ;;; specifiers' (6.7.2).
 

+;; Let's not repeat ourselves.
+(macrolet ((define-declaration-specifiers (&rest defs)
+            (let ((mappings nil)
+                  (deftypes nil)
+                  (hashvar (gensym "HASH"))
+                  (keyvar (gensym "KEY"))
+                  (valvar (gensym "VAL")))
+              (dolist (def defs)
+                (destructuring-bind (kind &rest clauses) def
+                  (let ((maps (mapcar (lambda (clause)
+                                        (if (consp clause)
+                                            clause
+                                            (cons (string-downcase clause)
+                                                  clause)))
+                                      clauses)))
+                    (push `(deftype ,(symbolicate 'decl- kind) ()
+                             '(member ,@(mapcar #'cdr maps)))
+                          deftypes)
+                    (setf mappings (nconc (remove-if-not #'car maps)
+                                          mappings)))))
+              `(progn
+                 ,@(nreverse deftypes)
+                 (defparameter *declspec-map*
+                   (let ((,hashvar (make-hash-table :test #'equal)))
+                     (mapc (lambda (,keyvar ,valvar)
+                             (setf (gethash ,keyvar ,hashvar) ,valvar))
+                           ',(mapcar #'car mappings)
+                           ',(mapcar #'cdr mappings))
+                     ,hashvar))))))
+  (define-declaration-specifiers
+    (type :char :int :float :double :void)
+    (size :short :long (nil . :long-long))
+    (sign :signed :unsigned)
+    (qualifier :const :restrict :volatile)
+    (tagged :enum :struct :union)))
+

 (defstruct (declspec
             (:predicate declspecp))
   "Represents a declaration specifier being built."
   (qualifiers nil :type list)
 (defstruct (declspec
             (:predicate declspecp))
   "Represents a declaration specifier being built."
   (qualifiers nil :type list)

-  (sign nil :type (member nil :signed :unsigned))
-  (size nil :type (member nil :short :long :long-long))
-  (type nil :type (or (member nil :int :char :float :double :void) c-type)))
+  (sign nil :type (or decl-sign null))
+  (size nil :type (or decl-size null))
+  (type nil :type (or decl-type c-type null)))

 
 (defun check-declspec (spec)
   "Check that the declaration specifiers in SPEC are a valid combination.
 
 (defun check-declspec (spec)
   "Check that the declaration specifiers in SPEC are a valid combination.


@@ -204,71 +240,58 @@
 
 (defun declaration-specifier-p (lexer)
   "Answer whether the current token might be a declaration specifier."
 
 (defun declaration-specifier-p (lexer)
   "Answer whether the current token might be a declaration specifier."

-  (case (token-type lexer)
-    ((:const :volatile :restrict
-      :signed :unsigned
-      :short :long
-      :void :char :int :float :double
-      :enum :struct :union)
-     t)
-    (:id
-     (gethash (token-value lexer) *type-map*))
-    (t
-     nil)))
+  (and (eq (token-type lexer) :id)
+       (let ((id (token-value lexer)))
+        (or (gethash id *declspec-map*)
+            (gethash id *type-map*)))))

 
 (defun parse-c-type (lexer)
   "Parse declaration specifiers from LEXER and return a C-TYPE."
 
   (let ((spec (make-declspec))
 
 (defun parse-c-type (lexer)
   "Parse declaration specifiers from LEXER and return a C-TYPE."
 
   (let ((spec (make-declspec))

-       (found-any nil))
-    (loop
-      (let ((tok (token-type lexer)))
-       (labels ((update (func value)
-                  (let ((new (funcall func spec value)))
-                    (cond (new (setf spec new))
-                          (t (cerror*
-          "Invalid declaration specifier ~(~A~) after `~{~A~^ ~}' (ignored)"
-                              (format-token tok (token-value lexer))
-                              (declspec-keywords spec t))
-                             nil))))
-                (tagged (class)
-                  (let ((kind tok))
-                    (setf tok (next-token lexer))
-                    (if (eql tok :id)
-                        (when (update #'update-declspec-type
-                                      (make-instance
-                                       class
-                                       :tag (token-value lexer)))
-                          (setf found-any t))
-                        (cerror* "Expected ~(~A~) tag; found ~A"
-                                 kind (format-token lexer))))))
-         (case tok
-           ((:const :volatile :restrict)
-            (update #'update-declspec-qualifiers tok))
-           ((:signed :unsigned)
-            (when (update #'update-declspec-sign tok)
-              (setf found-any t)))
-           ((:short :long)
-            (when (update #'update-declspec-size tok)
-              (setf found-any t)))
-           ((:void :char :int :float :double)
-            (when (update #'update-declspec-type tok)
-              (setf found-any t)))
-           (:enum (tagged 'c-enum-type))
-           (:struct (tagged 'c-struct-type))
-           (:union (tagged 'c-union-type))
-           (:id
-            (let ((ty (gethash (token-value lexer) *type-map*)))
-              (when (or found-any (not ty))
-                (return))
-              (when (update #'update-declspec-type ty)
-                (setf found-any t))))
-           (t
-            (return))))
-       (setf tok (next-token lexer))))
-    (unless found-any
-      (cerror* "Missing type name (guessing at `int')"))
-    (declspec-c-type spec)))
+       (found-any nil)
+       tok)
+    (flet ((token (&optional (ty (next-token lexer)))
+            (setf tok
+                  (or (and (eq ty :id)
+                           (gethash (token-value lexer) *declspec-map*))
+                      ty)))
+          (update (func value)
+            (let ((new (funcall func spec value)))
+              (cond (new (setf spec new))
+                    (t (cerror* "Invalid declaration specifier ~(~A~) ~
+                                 following `~{~A~^ ~}' (ignored)"
+                                (format-token tok (token-value lexer))
+                                (declspec-keywords spec t))
+                       nil)))))
+      (token (token-type lexer))
+      (loop
+       (typecase tok
+         (decl-qualifier (update #'update-declspec-qualifiers tok))
+         (decl-sign (when (update #'update-declspec-sign tok)
+                      (setf found-any t)))
+         (decl-size (when (update #'update-declspec-size tok)
+                      (setf found-any t)))
+         (decl-type (when (update #'update-declspec-type tok)
+                      (setf found-any t)))
+         (decl-tagged (let ((class (ecase tok
+                                     (:enum 'c-enum-type)
+                                     (:struct 'c-struct-type)
+                                     (:union 'c-union-type))))
+                        (let ((tag (require-token lexer :id)))
+                          (when tag
+                            (update #'update-declspec-type
+                                    (make-instance class :tag tag))))))
+         ((eql :id) (let ((ty (gethash (token-value lexer) *type-map*)))
+                      (when (or found-any (not ty))
+                        (return))
+                      (when (update #'update-declspec-type ty)
+                        (setf found-any t))))
+         (t (return)))
+       (token))
+      (unless found-any
+       (cerror* "Missing type name (guessing at `int')"))
+      (declspec-c-type spec))))

 
 ;;;--------------------------------------------------------------------------
 ;;; Parsing declarators.
 
 ;;;--------------------------------------------------------------------------
 ;;; Parsing declarators.


@@ -375,9 +398,8 @@
               (eq (token-type lexer) :id))
       (let ((name (token-value lexer)))
        (next-token lexer)
               (eq (token-type lexer) :id))
       (let ((name (token-value lexer)))
        (next-token lexer)

-       (cond ((and dottedp
-                   (eq (token-type lexer) #\.))
-              (let ((sub (require-token :id :default (gensym))))
+       (cond ((and dottedp (require-token lexer #\. :errorp nil))
+              (let ((sub (require-token lexer :id :default (gensym))))

                 (setf item (cons name sub))))
              (t
               (setf item name)))))
                 (setf item (cons name sub))))
              (t
               (setf item name)))))


@@ -407,6 +429,9 @@
                   (return)))
               (setf dims (nreverse dims))
               (push (lambda (ty)
                   (return)))
               (setf dims (nreverse dims))
               (push (lambda (ty)

+                      (when (typep ty 'c-function-type)
+                        (error "Array element type cannot be ~
+                                a function type"))

                       (make-instance 'c-array-type
                                      :dimensions dims
                                      :subtype ty))
                       (make-instance 'c-array-type
                                      :dimensions dims
                                      :subtype ty))


@@ -438,7 +463,6 @@
 
               ;; Catch: if the only thing in the list is `void' (with no
               ;; identifier) then kill the whole thing.
 
               ;; Catch: if the only thing in the list is `void' (with no
               ;; identifier) then kill the whole thing.

-              (break)

               (setf args
                     (if (and args
                              (null (cdr args))
               (setf args
                     (if (and args
                              (null (cdr args))


@@ -449,6 +473,9 @@
 
               ;; Stash the operator.
               (push (lambda (ty)
 
               ;; Stash the operator.
               (push (lambda (ty)

+                      (when (typep ty '(or c-function-type c-array-type))
+                        (error "Function return type cannot be ~
+                                a function or array type"))

                       (make-instance 'c-function-type
                                      :arguments args
                                      :subtype ty))
                       (make-instance 'c-function-type
                                      :arguments args
                                      :subtype ty))


@@ -486,22 +513,22 @@
 (with-input-from-string (in "
 //  int stat(struct stat *st)
 //  void foo(void)
 (with-input-from-string (in "
 //  int stat(struct stat *st)
 //  void foo(void)

-    int vsnprintf(size_t n, char *buf, va_list ap)
+  int vsnprintf(size_t n, char *buf, va_list ap)
+//  size_t size_t;

 //  int (*signal(int sig, int (*handler)(int s)))(int t)
 ")
   (let* ((stream (make-instance 'position-aware-input-stream
                                :file "<string>"
                                :stream in))
 //  int (*signal(int sig, int (*handler)(int s)))(int t)
 ")
   (let* ((stream (make-instance 'position-aware-input-stream
                                :file "<string>"
                                :stream in))

-        (lex (make-instance 'sod-lexer :stream stream
-                            :keywords *sod-keywords*)))
+        (lex (make-instance 'sod-lexer :stream stream)))

     (next-char lex)
     (next-token lex)
     (let ((ty (parse-c-type lex)))
       (multiple-value-bind (type name) (parse-c-declarator lex ty)
     (next-char lex)
     (next-token lex)
     (let ((ty (parse-c-type lex)))
       (multiple-value-bind (type name) (parse-c-declarator lex ty)

-       (multiple-value-bind (typestr declstr) (c-declaration type name)
-         (list ty
-               (list type name)
-               (list typestr declstr)
+       (list ty
+             (list type name)
+             (with-output-to-string (out)
+               (pprint-c-type type out name)

                (format-token lex)))))))
 
 ;;;----- That's all, folks --------------------------------------------------
                (format-token lex)))))))
 
 ;;;----- That's all, folks --------------------------------------------------