Massive reorganization in progress.

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

;;; -*-lisp-*-
;;;
;;; Parser for C types
;;;
;;; (c) 2009 Straylight/Edgeware
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This file is part of the Sensble Object Design, an object system for C.
;;;
;;; SOD is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; SOD is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with SOD; if not, write to the Free Software Foundation,
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

(cl:in-package #:sod)

;;;--------------------------------------------------------------------------
;;; Declaration specifiers.

(defclass declspec ()
  ((label :type keyword :initarg :label :reader ds-label)
   (name :type string :initarg :name :reader ds-name)
   (kind :type (member type sign size qualifier tagged)
	 :initarg :kind :reader ds-kind)))

(defmethod shared-initialize :after ((ds declspec) slot-names &key)
  (default-slot (ds 'name slot-names)
    (string-downcase (ds-label ds))))

(defclass declspecs ()
  ((type :initform nil :initarg :type :reader ds-type)
   (sign :initform nil :initarg :sign :reader ds-sign)
   (size :initform nil :initarg :size :reader ds-size)
   (qualifier :initform nil :initarg :qualifiers :reader ds-qualifiers)))

(defparameter *declspec-map*
  (let ((map (make-hash-table :test #'equal)))
    (dolist (item '((type :void :char :int :float :double)
		    (size :short :long (:long-long "long long"))
		    (sign :signed :unsigned)
		    (qualifier :const :restrict :volatile)
		    (tagged :enum :struct :union)))
      (let ((kind (car item)))
	(dolist (spec (cdr item))
	  (multiple-value-bind (label name)
	      (if (consp spec)
		  (values (car spec) (cadr spec))
		  (values spec (string-downcase spec)))
	    (let ((ds (make-instance 'declspec
				     :label label :name name :kind kind)))
	      (setf (gethash name map) ds
		    (gethash label map) ds))))))
    map))

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

(defparameter *good-declspecs*
  '(((:int) (:signed :unsigned) (:short :long :long-long))
    ((:char) (:signed :unsigned) ())
    ((:double) () (:long))
    (t () ()))
  "List of good collections of declaration specifiers.

   Each item is a list of the form (TYPES SIGNS SIZES).  Each of TYPES, SIGNS
   and SIZES is either a list of acceptable specifiers of the appropriate
   kind, or T, which matches any specifier.")

(defun scan-declspec (scanner)
  "Scan a DECLSPEC from SCANNER.

   Value on success is either a DECLSPEC object or a C-TYPE object."

  ;; Turns out to be easier to do this by hand.
  (let ((ds (and (eq (token-type scanner) :id)
		 (let ((kw (token-value scanner)))
		   (or (gethash kw *declspec-map*)
		       (gethash kw *module-type-map*))))))
    (cond ((not ds)
	   (values (list :declspec) nil nil))
	  ((eq (ds-kind ds) :tagged)
	   (scanner-step scanner)
	   (if (eq (token-type scanner) :id)
	       (let ((ty (make-c-tagged-type (ds-label ds)
					     (token-value scanner))))
		 (scanner-step scanner)
		 (values ty t t))
	       (values :tag nil t)))
	  (t
	   (scanner-step scanner)
	   (values ds t t)))))

(defun good-declspecs-p (specs)
  "Are SPECS a good collection of declaration specifiers?"
  (let ((speclist (list (ds-type specs) (ds-sign specs) (ds-size specs))))
    (some (lambda (it)
	    (every (lambda (spec pat)
		     (or (eq pat t) (null spec)
			 (member (ds-label spec) pat)))
		   speclist it))
	  *good-declspecs*)))

(defun combine-declspec (specs ds)
  "Combine the declspec DS with the existing SPECS.

   Returns new DECLSPECS if they're OK, or `nil' if not.  The old SPECS are
   not modified."
  (let* ((kind (ds-kind ds))
	 (old (slot-value specs kind)))
    (multiple-value-bind (ok new)
	(case kind
	  (qualifier (values t (adjoin ds old)))
	  (size (cond ((not old) (values t ds))
		      ((and (eq (ds-label old) :long) (eq ds old))
		       (values t (gethash :long-long *declspec-map*)))
		      (t (values nil nil))))
	  (t (values (not old) ds)))
      (if ok
	  (let ((copy (copy-instance specs)))
	    (setf (slot-value copy kind) new)
	    (and (good-declspecs-p copy) copy))
	  nil))))

(defun scan-and-merge-declspec (scanner specs)
  (with-parser-context (token-scanner-context :scanner scanner)
    (if-parse (:consumedp consumedp) (scan-declspec scanner)
      (aif (combine-declspec specs it)
	   (values it t consumedp)
	   (values (list :declspec) nil consumedp)))))

(defun declspecs-type (specs)
  (let ((type (ds-type specs))
	(size (ds-size specs))
	(sign (ds-sign specs)))
    (cond ((or type size sign)
	   (when (and (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-label
					     (remove nil
						     (list sign size type))))
			     (mapcar #'ds-label (ds-qualifiers specs))))
	  (t
	   nil))))

(defun parse-c-type (scanner)
  (with-parser-context (token-scanner-context :scanner scanner)
    (if-parse (:result specs :consumedp cp)
	      (many (specs (make-instance 'declspecs) it :min 1)
		(scan-and-merge-declspec scanner specs))
	      (let ((type (declspecs-type specs)))
		(if type (values type t cp)
		    (values (list :declspec) nil cp))))))











  ;; This is rather complicated, but extracting all the guts into a structure
  ;; and passing it around makes matters worse rather than better.
  ;;
  ;; We categorize declaration specifiers into four kinds.
  ;;
  ;;   * `Type specifiers' describe the actual type, whether that's integer,
  ;;	 character, floating point, or some tagged or user-named type.
  ;;
  ;;   * `Size specifiers' distinguish different sizes of the same basic
  ;;	 type.  This is how we tell the difference between `int' and `long'.
  ;;
  ;;   * `Sign specifiers' distinguish different signednesses.  This is how
  ;;	 we tell the difference between `int' and `unsigned'.
  ;;
  ;;   * `Qualifiers' are our old friends `const', `restrict' and `volatile'.
  ;;
  ;; These groupings are for our benefit here, in determining whether a
  ;; particular declaration specifier is valid in the current context.  We
  ;; don't accept `function specifiers' (of which the only current example is
  ;; `inline') since it's meaningless to us.
  ;;
  ;; Our basic strategy is to parse declaration specifiers while they're
  ;; valid, and keep track of what we've read.  When we've reached the end,
  ;; we'll convert what we've got into a `canonical form', and then convert
  ;; that into a C type object of the appropriate kind.

  (let ((specs (make-instance 'declspecs)))
    

  (let ((toks nil) (type nil) (size nil) (sign nil) (quals nil))
    (labels ((goodp (ty sg sz)
	       "Are (TY SG SZ) a good set of declaration specifiers?"
	       (some (lambda (it)
		       (every (lambda (spec pat)
				(or (eq pat t) (eq spec nil)
				    (member spec pat)))
			      decls it))
		     *good-declspecs*))

	     (scan-declspec ()
	       "Scan a declaration specifier."
	       (flet ((win (value &optional (consumedp t))
			(when consumedp (scanner-step scanner))
			(return-from scan-declspec
			  (values value t consumedp)))
		      (lose (wanted &optional (consumedp nil))
			(values wanted nil consumedp)))
		 (unless (eq (token-type scanner) :id) (lose :declspec))
		 (let* ((id (token-value scanner))
			(ds (or (gethash id *declspec-map*)
				(gethash id *module-type-map*))))
		   (unless ds (lose :declspec))
		   (let ((label (ds-label ds)))
		     (ecase (ds-kind ds)
		       (:qualifier
			(push (ds-label ds) quals)
			(win ds))
		       (:size
			(cond ((and (not size) (goodp type label sign))
			       (setf size label)
			       (win ds))
			      (t
			       (lose :declspec))))
		       (:sign
			(cond ((and (not sign) (goodp type size label))
			       (setf sign label)
			       (win ds))
			      (t
			       (lose :declspec))))
		       (:type
			(when (and (eq type :long) (eq label :long))
			  (setf label :long-long))
			(cond ((and (or (not type) (eq type :long))
				    (goodp label size sign))
			       (setf type label)
			       (win ds))
			      (t
			       (lose :declspec))))
		       (:tagged
			(unless (and (not type) (goodp label size sign))
			  (lose :declspec))
			(scanner-step scan)
			(unless (eq (token-type scanner) :id)
			  (lose :tagged t))
			(setf type
			      (make-c-tagged-type label
						  (token-value scanner)))
			(win type))))))))

      (with-parser-context (token-scanner-context :scanner scanner)
	(many (nil nil nil :min 1)
	  (scan-declspec))




  (let ((toks nil) (type nil) (size nil) (sign nil) (quals nil))
    (labels ((check (ty sz sg)
	       (case ty
		 ((nil :int) t)
		 (:char (null sz))
		 (:double (and (null sg) (or (null sz) (eq sz :long))))
		 (t (and (null sg) (null sz)))))
	     (set-type (ty)
	       (when ))
	     (set-size (sz)
	       (when (and (eq sz :long) (eq size :long))
		 (setf sz :long-long))
	       (when (and (or (null size) (eq sz :long-long))
			  (check type sz sign))
		 (setf size sz)))
	     (set-sign (sg)
	       (when (and (null sign) (check type size sg))
		 (setf sign sg)))
	     (parse-declspec ()
	       (multiple-value-bind (kind value)
		   (categorize-declspec scanner)
		 (if (ecase kind
		       (:qualifier (push value quals))
		       (:type (and (null type) (check value size sign)
				   (setf type value)))
		       (:size (let ((sz (if (and (eq size :long)
						 (eq value :long))
					    :long-long value)))
				(and (or (null size) (eq sz :long-long))
				     (check type value sign)
				     (setf size value))))
		       (:sign (and (null sign) (check type size value)
				   (setf sign value)))
		       

;;;----- That's all, folks --------------------------------------------------