;; 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))
((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)))
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)
(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.
((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))
- (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.
(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.
;;; `parse-declarator' will be of this form.
(export 'parse-declarator)
-(defun parse-declarator (scanner base-type &key kernel abstractp)
+(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
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.
+
(with-parser-context (token-scanner-context :scanner scanner)
(let ((kernel-parser (cond (kernel kernel)
(abstractp (parser () (? :id)))
'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))))))
(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 [`,' argument]* [`,' `...']] | `...'
+ ;; 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))
+ (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)
- (parse (seq ((base-type (parse-c-type scanner))
- (dtor (parse-declarator scanner
- base-type
- :abstractp t)))
- (make-argument (cdr dtor) (car dtor))))
+ (argument)
(unless winp
(if (or consumedp args)
(return-from argument-list (values arg nil t))
(unless (eq (token-type scanner) #\,)
(return))
(scanner-step scanner))
- (values (nreverse args) t args)))
+ (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 (#\( (args (argument-list)) #\))
+ (parse (seq (#\( (make (argument-list)) #\))
(postop "()" (state 10)
(cons (lambda (type)
+ (disallow-keyword-functions type)
(funcall (car state)
- (make-function-type type args)))
+ (funcall make type)))
(cdr state))))))
(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)))))))
(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 --------------------------------------------------
~mdw / sod / blobdiff