X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/aa14a4cddcb96b681d5c19a2ec8bad382f43b264..f458e64e36509fa8c204f1dbcafff1d3dc059619:/src/c-types-parse.lisp diff --git a/src/c-types-parse.lisp b/src/c-types-parse.lisp index ba6bf6f..9c33672 100644 --- a/src/c-types-parse.lisp +++ b/src/c-types-parse.lisp @@ -7,7 +7,7 @@ ;;;----- 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 @@ -65,19 +65,20 @@ ;; `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. + ;; 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. @@ -88,73 +89,87 @@ (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.") + "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. + ;; 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) @@ -177,6 +192,7 @@ ((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))) @@ -186,36 +202,46 @@ (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 "") -(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, @@ -229,11 +255,13 @@ ;; 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) @@ -245,6 +273,34 @@ (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. @@ -254,11 +310,14 @@ 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. @@ -288,122 +347,233 @@ ;;; (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 --------------------------------------------------