;;;----- Licensing notice ---------------------------------------------------
;;;
-;;; This file is part of the Sensble Object Design, an object system for C.
+;;; This file is part of the Sensible 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
;; `inline') since it's meaningless to me.
(defclass declspec ()
- ;; This could have been done with DEFSTRUCT just as well, but a DEFCLASS
- ;; can be tweaked interactively, which is a win at the moment.
- ((label :type keyword :initarg :label :reader ds-label)
+ ;; Despite the fact that it looks pretty trivial, this can't be done with
+ ;; `defstruct' for the simple reason that we add more methods to the
+ ;; accessor functions later.
+ ((%label :type keyword :initarg :label :reader ds-label)
(name :type string :initarg :name :reader ds-name)
- (kind :type (member type 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))
(:documentation
"Represents the important components of a declaration specifier.
- The only interesting instances of this class are in the table
- `*declspec-map*'."))
+ The only interesting instances of this class are in the table
+ `*declspec-map*'."))
(defmethod shared-initialize :after ((ds declspec) slot-names &key)
"If no name is provided then derive one from the label.
(defparameter *declspec-map*
(let ((map (make-hash-table :test #'equal)))
- (dolist (item '((type :void :char :int :float :double)
+ (dolist (item '((%type :char :int :float :double)
+ (complexity (:complex :compat "_Complex")
+ (:imaginary :compat "_Imaginary"))
((type :taggedp t) :enum :struct :union)
(size :short :long (:long-long :name "long long"))
(sign :signed :unsigned)
- (qualifier :const :restrict :volatile)))
+ (qualifier :const :restrict :volatile
+ (:atomic :compat "_Atomic"))))
(destructuring-bind (kind &key (taggedp nil))
(let ((spec (car item)))
(if (consp spec) spec (list spec)))
(dolist (spec (cdr item))
(destructuring-bind (label
- &key
- (name (string-downcase label))
- (taggedp taggedp))
+ &key (name (string-downcase label))
+ compat (taggedp taggedp))
(if (consp spec) spec (list spec))
(let ((ds (make-instance 'declspec
:label label
- :name name
+ :name (or compat name)
:kind kind
:taggedp taggedp)))
(setf (gethash name map) ds
- (gethash label map) ds))))))
+ (gethash label map) ds)
+ (when compat
+ (setf (gethash compat map) ds)))))))
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)
+
;; A collection of declaration specifiers, and how to merge them together.
(defclass declspecs ()
- ;; Despite the fact that it looks pretty trivial, this can't be done with
- ;; DEFCLASS for the simple reason that we add more methods to the accessor
- ;; functions later.
- ((type :initform nil :initarg :type :reader ds-type)
+ ;; This could have been done with `defstruct' just as well, but a
+ ;; `defclass' can be tweaked interactively, which is a win at the moment.
+ ((%type :initform nil :initarg :type :reader ds-type)
+ (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.
-
- This is used during type parsing to represent the type under
- construction. Instances are immutable: we build new ones rather than
- modifying existing ones. This leads to a certain amount of churn, but
- we'll just have to live with that.
+ (:documentation "Represents a collection of declaration specifiers.
- (Why are instances immutable? Because it's much easier to merge a new
- specifier into an existing collection and then check that the resulting
- thing is valid, rather than having to deal with all of the possible
- special cases of what the new thing might be. And if the merged
- collection isn't good, I must roll back to the previous version. So I
- don't get to take advantage of a mutable structure.)"))
+ This is used during type parsing to represent the type under construction.
+ Instances are immutable: we build new ones rather than modifying existing
+ ones. This leads to a certain amount of churn, but we'll just have to
+ live with that.
-(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)
+ (Why are instances immutable? Because it's much easier to merge a new
+ specifier into an existing collection and then check that the resulting
+ thing is valid, rather than having to deal with all of the possible
+ special cases of what the new thing might be. And if the merged
+ collection isn't good, I must roll back to the previous version. So I
+ don't get to take advantage of a mutable structure.)"))
(defparameter *good-declspecs*
- '(((:int) (:signed :unsigned) (:short :long :long-long))
- ((:char) (:signed :unsigned) ())
- ((:double) () (:long))
- (t () ()))
+ '(((:int) (:signed :unsigned) (:short :long :long-long) ())
+ ((:char) (:signed :unsigned) () ())
+ ((:double) () (:long) (:complex :imaginary))
+ (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.")
+ Each item is a list of the form (TYPES SIGNS SIZES COMPLEXITIES). Each of
+ TYPES, SIGNS, SIZES, and COMPLEXITIES, is either a list of acceptable
+ specifiers of the appropriate kind, or T, which matches any specifier.")
(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))))
+ (let ((speclist (list (ds-type specs)
+ (ds-sign specs)
+ (ds-size specs)
+ (ds-complexity specs))))
(some (lambda (it)
(every (lambda (spec pat)
(or (eq pat t) (null spec)
((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)))
(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))
- (quals (mapcar #'ds-label (ds-qualifiers specs))))
- (cond ((typep type 'c-type)
- (qualify-c-type type quals))
- ((or type size sign)
- (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-label
- (remove nil
- (list sign 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.
(define-indicator :declspec "<declaration-specifier>")
-(defun scan-declspec
+(defun scan-simple-declspec
(scanner &key (predicate (constantly t)) (indicator :declspec))
- "Scan a `declspec' from SCANNER.
+ "Scan a simple `declspec' from SCANNER.
+
+ Simple declspecs are the ones defined in the `*declspec-map*' or
+ `*module-type-map*'. This covers the remaining possibilities if the
+ `complex-declspec' pluggable parser didn't find anything to match.
If PREDICATE is provided then only succeed if (funcall PREDICATE DECLSPEC)
is true, where DECLSPEC is the raw declaration specifier or 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 *module-type-map*)
- (gethash kw *declspec-map*))))))
+ (or (gethash kw *declspec-map*)
+ (and (boundp '*module-type-map*)
+ (gethash kw *module-type-map*))
+ (find-simple-c-type kw))))))
(cond ((or (not ds) (and predicate (not (funcall predicate ds))))
(values (list indicator) nil nil))
- ((ds-taggedp ds)
+ ((and (typep ds 'declspec) (ds-taggedp ds))
(scanner-step scanner)
(if (eq (token-type scanner) :id)
(let ((ty (make-c-tagged-type (ds-label ds)
(scanner-step scanner)
(values ds t t)))))
+(define-pluggable-parser complex-declspec atomic-typepsec (scanner)
+ ;; `atomic' `(' type-name `)'
+ ;; `_Atomic' `(' type-name `)'
+ (with-parser-context (token-scanner-context :scanner scanner)
+ (parse (peek (seq ((nil (or "atomic" "_Atomic"))
+ #\(
+ (decls (parse-c-type scanner))
+ (subtype (parse-declarator scanner decls
+ :kernel (parse-empty)
+ :abstractp t))
+ #\))
+ (make-atomic-type (car subtype)))))))
+
+(define-pluggable-parser complex-declspec alignas (scanner)
+ ;; `alignas' `(' fragment `)'
+ ;; `_Alignas' `(' fragment `)'
+ (with-parser-context (token-scanner-context :scanner scanner)
+ (parse (peek (seq ((nil (or "alignas" "_Alignas"))
+ (nil (lisp (values #\(
+ (eq (token-type scanner) #\()
+ nil)))
+ (nil (commit))
+ (frag (parse-delimited-fragment scanner #\( #\))))
+ (make-instance 'storespec
+ :spec (make-instance
+ 'alignas-storage-specifier
+ :alignment frag)))))))
+
(defun scan-and-merge-declspec (scanner specs)
"Scan a declaration specifier and merge it with SPECS.
SPECS."
(with-parser-context (token-scanner-context :scanner scanner)
- (if-parse (:consumedp consumedp) (scan-declspec scanner)
+ (if-parse (:consumedp consumedp)
+ (or (plug complex-declspec scanner)
+ (scan-simple-declspec scanner))
(aif (combine-declspec specs it)
(values it t consumedp)
(values (list :declspec) nil consumedp)))))
+(export 'parse-c-type)
(defun parse-c-type (scanner)
"Parse a C type from declaration specifiers.
;;; (funcall FUNC TYPE) returns the derived type. The result of
;;; `parse-declarator' will be of this form.
-(defun parse-declarator (scanner base-type &key abstractp)
- (with-parser-context (token-scanner-context :scanner scanner)
+(export 'parse-declarator)
+(defun parse-declarator (scanner base-type &key kernel abstractp keywordp)
+ "Parse a C declarator, returning a pair (C-TYPE . NAME).
+
+ The SCANNER is a token scanner to read from. The BASE-TYPE is the type
+ extracted from the preceding declaration specifiers, as parsed by
+ `parse-c-type'.
+
+ The result contains both the resulting constructed C-TYPE (with any
+ qualifiers etc. as necessary), and the name from the middle of the
+ declarator. The name is parsed using the KERNEL parser provided, and
+ defaults to matching a simple identifier `:id'. This might, e.g., be
+ (? :id) to parse an `abstract declarator' which has optional names.
+
+ If KEYWORDP is true, then a keyword argument list is permitted in
+ function declarations.
+
+ There's an annoying ambiguity in the syntax, if an empty KERNEL is
+ permitted. In this case, you must ensure that ABSTRACTP is true so that
+ the appropriate heuristic can be applied. As a convenience, if ABSTRACTP
+ is true then `(? :id)' is used as the default KERNEL."
+
+ ;; This is a bit confusing. This is a strangely-shaped operator grammer,
+ ;; which wouldn't be so bad, but the `values' being operated on are pairs
+ ;; of the form (FUNC . NAME). The NAME is whatever the KERNEL parser
+ ;; produces as its result, and will be passed out unchanged. The FUNC is a
+ ;; type-constructor function which will be eventually be applied to the
+ ;; input BASE-TYPE, but we can't calculate the actual result as we go along
+ ;; because of the rather annoying inside-out nature of the declarator
+ ;; syntax.
- (labels ((qualifiers ()
- ;; QUALIFIER*
-
- (parse
- (seq ((quals (list ()
- (scan-declspec
- scanner
- :indicator :qualifier
- :predicate (lambda (ds)
- (and (typep ds 'declspec)
- (eq (ds-kind ds)
- 'qualifier)))))))
- (mapcar #'ds-label quals))))
-
- (star ()
- ;; Prefix: `*' QUALIFIERS
-
- (parse (seq (#\* (quals (qualifiers)))
- (preop "*" (state 9)
- (cons (lambda (type)
- (funcall (car state)
- (make-pointer-type type quals)))
- (cdr state))))))
-
- (prefix-lparen ()
- ;; Prefix: `('
- ;;
- ;; Opening parentheses are treated as prefix operators by the
- ;; expression parsing engine. There's an annoying ambiguity
- ;; in the syntax if abstract declarators are permitted: a `('
- ;; might be either the start of a nested subdeclarator or the
- ;; start of a postfix function argument list. The two are
- ;; disambiguated by stating that if the token following the
- ;; `(' is a `)' or a declaration specifier, then we have a
- ;; postfix argument list.
-
- (parse
- (peek (seq (#\(
- (nil (if (and abstractp
- (eq (token-type scanner) :id)
- (let ((id (token-value scanner)))
- (or (gethash id
- *module-type-map*)
- (gethash id
- *declspec-map*))))
- (values nil nil nil)
- (values t t nil))))
- (lparen #\))))))
-
- (centre ()
- ;; ID | empty
- ;;
- ;; The centre might be empty or contain an identifier,
- ;; depending on the setting of ABSTRACTP.
-
- (parse (or (when (not (eq abstractp t))
- (seq ((id :id)) (cons #'identity id)))
- (when abstractp
- (t (cons #'identity nil))))))
-
- (argument-list ()
- ;; [ ARGUMENT [ `,' ARGUMENT ]* ]
-
- (parse (list ()
- (seq ((base-type (parse-c-type scanner))
- (dtor (parse-declarator scanner
- base-type
- :abstractp :maybe)))
- (make-argument (cdr dtor) (car dtor)))
- #\,)))
-
- (postfix-lparen ()
- ;; Postfix: `(' ARGUMENT-LIST `)'
-
- (parse (seq (#\( (args (argument-list)) #\))
- (postop "()" (state 9)
- (cons (lambda (type)
- (funcall (car state)
- (make-function-type type args)))
- (cdr state))))))
-
- (dimension ()
- ;; `[' C-FRAGMENT ']'
-
- (parse-delimited-fragment scanner #\[ #\]))
-
- (lbracket ()
- ;; Postfix: DIMENSION+
-
- (parse (seq ((dims (list (:min 1) (dimension))))
- (postop "[]" (state 10)
- (cons (lambda (type)
- (funcall (car state)
- (make-array-type type dims)))
- (cdr state)))))))
-
- ;; And now we actually do the declarator parsing.
- (parse (seq ((value (expr (:nestedp nestedp)
-
- ;; An actual operand.
- (centre)
-
- ;; Binary operators. There aren't any.
- nil
-
- ;; Prefix operators.
- (or (star)
- (prefix-lparen))
-
- ;; Postfix operators.
- (or (postfix-lparen)
- (lbracket)
- (when nestedp (seq (#\)) (rparen #\))))))))
- (cons (funcall (car value) base-type) (cdr value)))))))
+ (with-parser-context (token-scanner-context :scanner scanner)
+ (let ((kernel-parser (cond (kernel kernel)
+ (abstractp (parser () (? :id)))
+ (t (parser () :id)))))
+
+ (labels ((qualifiers ()
+ ;; qualifier*
+
+ (parse
+ (seq ((quals (list ()
+ (scan-simple-declspec
+ scanner
+ :indicator :qualifier
+ :predicate (lambda (ds)
+ (and (typep ds 'declspec)
+ (eq (ds-kind ds)
+ 'qualifier)))))))
+ (mapcar #'ds-label quals))))
+
+ (disallow-keyword-functions (type)
+ (when (typep type 'c-keyword-function-type)
+ (error "Functions with keyword arguments are only ~
+ allowed at top-level")))
+
+ (star ()
+ ;; Prefix: `*' qualifiers
+
+ (parse (seq (#\* (quals (qualifiers)))
+ (preop "*" (state 9)
+ (cons (lambda (type)
+ (disallow-keyword-functions type)
+ (funcall (car state)
+ (make-pointer-type type quals)))
+ (cdr state))))))
+
+ (predict-argument-list-p ()
+ ;; See `prefix-lparen'. Predict an argument list rather
+ ;; than a nested declarator if (a) abstract declarators are
+ ;; permitted and (b) the next token is a declaration
+ ;; specifier or ellipsis.
+ (let ((type (token-type scanner))
+ (value (token-value scanner)))
+ (and abstractp
+ (or (eq type :ellipsis)
+ (and (eq type :id)
+ (or (gethash value *module-type-map*)
+ (gethash value *declspec-map*)))))))
+
+ (prefix-lparen ()
+ ;; Prefix: `('
+ ;;
+ ;; Opening parentheses are treated as prefix operators by
+ ;; the expression parsing engine. There's an annoying
+ ;; ambiguity in the syntax if abstract declarators are
+ ;; permitted: a `(' might be either the start of a nested
+ ;; subdeclarator or the start of a postfix function argument
+ ;; list. The two are disambiguated by stating that if the
+ ;; token following the `(' is a `)' or a declaration
+ ;; specifier, then we have a postfix argument list.
+ (parse
+ (peek (seq (#\(
+ (nil (if (predict-argument-list-p)
+ (values nil nil nil)
+ (values t t nil))))
+ (lparen #\))))))
+
+ (kernel ()
+ (parse (seq ((name (funcall kernel-parser)))
+ (cons #'identity name))))
+
+ (arg-decl (abstractp)
+ (parse (seq ((base-type (parse-c-type scanner))
+ (dtor (parse-declarator scanner base-type
+ :abstractp abstractp)))
+ dtor)))
+
+ (argument ()
+ ;; argument ::= type abstract-declspec
+
+ (parse (seq ((dtor (arg-decl t)))
+ (make-argument (cdr dtor) (car dtor)))))
+
+ (kw-argument ()
+ ;; kw-argument ::= type declspec [= c-fragment]
+
+ (parse (seq ((dtor (arg-decl nil))
+ (dflt (? (when (eq (token-type scanner) #\=)
+ (parse-delimited-fragment
+ scanner #\= '(#\, #\))
+ :keep-end t)))))
+ (make-argument (cdr dtor) (car dtor) dflt))))
+
+ (argument-list ()
+ ;; argument-list ::=
+ ;; [argument [`,' argument]* [`,' argument-tail]]
+ ;; | argument-tail
+ ;;
+ ;; argument-tail ::= `...' | keyword-tail
+ ;;
+ ;; keyword-tail ::= `?' [kw-argument [`,' kw-argument]*]
+ ;;
+ ;; kw-argument ::= argument [= c-fragment]
+ ;;
+ ;; The possibility of a trailing `,' `...' means that we
+ ;; can't use the standard `list' parser. Note that, unlike
+ ;; `real' C, we allow an ellipsis even if there are no
+ ;; explicit arguments.
+
+ (let ((args nil)
+ (keys nil)
+ (keysp nil))
+ (loop
+ (when (eq (token-type scanner) :ellipsis)
+ (push :ellipsis args)
+ (scanner-step scanner)
+ (return))
+ (when (and keywordp (eq (token-type scanner) #\?))
+ (setf keysp t)
+ (scanner-step scanner)
+ (multiple-value-bind (arg winp consumedp)
+ (parse (list (:min 0) (kw-argument) #\,))
+ (declare (ignore consumedp))
+ (unless winp
+ (return-from argument-list (values arg nil t)))
+ (setf keys arg)
+ (return)))
+ (multiple-value-bind (arg winp consumedp)
+ (argument)
+ (unless winp
+ (if (or consumedp args)
+ (return-from argument-list (values arg nil t))
+ (return)))
+ (push arg args))
+ (unless (eq (token-type scanner) #\,)
+ (return))
+ (scanner-step scanner))
+ (values (let ((rargs (nreverse args))
+ (rkeys (nreverse keys)))
+ (if keysp
+ (lambda (ret)
+ (make-keyword-function-type
+ ret rargs rkeys))
+ (lambda (ret)
+ (make-function-type ret rargs))))
+ t
+ (or args keysp))))
+
+ (postfix-lparen ()
+ ;; Postfix: `(' argument-list `)'
+
+ (parse (seq (#\( (make (argument-list)) #\))
+ (postop "()" (state 10)
+ (cons (lambda (type)
+ (disallow-keyword-functions type)
+ (funcall (car state)
+ (funcall make type)))
+ (cdr state))))))
+
+ (dimension ()
+ ;; `[' c-fragment ']'
+
+ (parse (seq ((frag (parse-delimited-fragment
+ scanner #\[ #\])))
+ (c-fragment-text frag))))
+
+ (lbracket ()
+ ;; Postfix: dimension+
+
+ (parse (seq ((dims (list (:min 1) (dimension))))
+ (postop "[]" (state 10)
+ (cons (lambda (type)
+ (disallow-keyword-functions type)
+ (funcall (car state)
+ (make-array-type type dims)))
+ (cdr state)))))))
+
+ ;; And now we actually do the declarator parsing.
+ (parse (seq ((value (expr (:nestedp nestedp)
+
+ ;; An actual operand.
+ (kernel)
+
+ ;; Binary operators. There aren't any.
+ nil
+
+ ;; Prefix operators.
+ (or (star)
+ (prefix-lparen))
+
+ ;; Postfix operators.
+ (or (postfix-lparen)
+ (lbracket)
+ (when nestedp (seq (#\)) (rparen #\))))))))
+ (cons (wrap-c-type (lambda (type)
+ (funcall (car value) type))
+ base-type)
+ (cdr value))))))))
;;;----- That's all, folks --------------------------------------------------
~mdw / sod / blobdiff