X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/abdf50aad1a95f1df8d11c54ff1623077eb84193..a07d8d005f69c0f9f5da2e09c6ee39cb1e1801aa:/parse-c-types.lisp

diff --git a/parse-c-types.lisp b/parse-c-types.lisp
index 702ae77..63e8b9b 100644
--- 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).
 
+;; 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)
-  (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.
@@ -204,71 +240,58 @@
 
 (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))
-	(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.
@@ -375,9 +398,8 @@
 	       (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)))))
@@ -407,6 +429,9 @@
 		   (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))
@@ -438,7 +463,6 @@
 
 	       ;; 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))
@@ -449,6 +473,9 @@
 
 	       ;; 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))
@@ -486,22 +513,22 @@
 (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))
-	 (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)
-	(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 --------------------------------------------------