X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/9ec578d9fe450b7e7f9030dc9d930185593aa991..c6b4ed992d81518f240509e6ab212d8fe705485a:/src/c-types-parse.lisp diff --git a/src/c-types-parse.lisp b/src/c-types-parse.lisp index 4a8e1d7..d0b3d41 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 @@ -68,17 +68,17 @@ ;; 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) + ((%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. @@ -89,72 +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.") +(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 () ;; 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) + ((%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-name - (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,7 +310,9 @@ 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))))) @@ -290,7 +348,7 @@ ;;; `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 @@ -303,10 +361,23 @@ 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))) @@ -317,7 +388,7 @@ (parse (seq ((quals (list () - (scan-declspec + (scan-simple-declspec scanner :indicator :qualifier :predicate (lambda (ds) @@ -326,23 +397,34 @@ '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)))))) - (next-declspec-p () - ;; Ansert whether the next token is a valid declaration - ;; specifier, without consuming it. - (and (eq (token-type scanner) :id) - (let ((id (token-value scanner))) - (or (gethash id *module-type-map*) - (gethash id *declspec-map*))))) + (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: `(' @@ -357,7 +439,7 @@ ;; specifier, then we have a postfix argument list. (parse (peek (seq (#\( - (nil (if (and abstractp (next-declspec-p)) + (nil (if (predict-argument-list-p) (values nil nil nil) (values t t nil)))) (lparen #\)))))) @@ -366,25 +448,92 @@ (parse (seq ((name (funcall kernel-parser))) (cons #'identity name)))) - (argument-list () - ;; [ argument [ `,' argument ]* ] + (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))))) - (parse (list (:min 0) - (seq ((base-type (parse-c-type scanner)) - (dtor (parse-declarator scanner - base-type - :abstractp 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 (#\( (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 () @@ -400,6 +549,7 @@ (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))))))) @@ -421,6 +571,9 @@ (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 --------------------------------------------------