;;;; This file contains definitions of types used to store meta information on ;;;; C++ types. Along with data defintions, you will find various functions ;;;; and methods for operating on that data. (in-package #:lcp) (named-readtables:in-readtable lcp:lcp-syntax) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Supported and unsupported C++ types (deftype general-cpp-type () '(or cpp-type unsupported-cpp-type)) (defgeneric cpp-type-decl (cpp-type &key namespacep globalp enclosing-classes-p type-params-p) (:documentation "Return the C++ type declaration corresponding to the given object.")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Supported C++ types (defvar +cpp-primitive-type-names+ '("bool" "char" "int" "int16_t" "int32_t" "int64_t" "uint" "uint16_t" "uint32_t" "uint64_t" "float" "double")) (defclass cpp-type () ((documentation :type (or null string) :initarg :documentation :initform nil :reader cpp-type-documentation :documentation "Documentation string for this C++ type.") (namespace :type list :initarg :namespace :initform nil :reader cpp-type-namespace :documentation "A list of strings naming the individual namespace parts of the namespace of this type. Enclosing classes aren't included, even though they form valid C++ namespaces.") (enclosing-classes :type list :initarg :enclosing-classes :initform nil :reader cpp-type-enclosing-classes :accessor %cpp-type-enclosing-classes :documentation "A list of strings naming the enclosing classes of this type.") (name :type string :initarg :name :reader cpp-type-name :documentation "The name of this type.") (type-params :type list :initarg :type-params :initform nil :reader cpp-type-type-params :documentation "A list of strings naming the template parameters that are needed to instantiate a concrete type. For example, in `template class vector`, `TValue' is the type parameter.") (type-args :type list :initarg :type-args :initform nil :reader cpp-type-type-args :accessor %cpp-type-type-args :documentation "A list of `CPP-TYPE' instances that represent the template type arguments used within the instantiation of the template. For example in `std::vector`, `int' is a template type argument.")) (:documentation "Base class for meta information on C++ types.")) (defun make-cpp-type (name &key namespace enclosing-classes type-params type-args) "Create an instance of CPP-TYPE. The keyword arguments correspond to the slots of the class CPP-TYPE and expect values according to their type and documentation, except as noted below. If the first element of NAMESPACE is an empty string, it is removed. NAMESPACE parts must not contain characters from +WHITESPACE-CHARS+. TYPE-ARGS can be a list of CPP-TYPE designators, each of which will be coerced into a CPP-TYPE instance as if by ENSURE-CPP-TYPE. TYPE-PARAMS and TYPE-ARGS cannot be provided simultaneously." (check-type name string) (check-type namespace list) (check-type enclosing-classes list) (check-type type-params list) (check-type type-args list) (dolist (list (list namespace enclosing-classes type-params)) (dolist (elem list) (check-type elem string))) (let ((namespace (if (and namespace (string= (car namespace) "")) (cdr namespace) namespace))) (dolist (part namespace) (when (or (string= part "") (find-if (lambda (c) (member c +whitespace-chars+ :test #'char=)) part)) (error "~@" part namespace))) (when (and type-params type-args) (error "~@")) (make-instance 'cpp-type :name name :namespace namespace :enclosing-classes enclosing-classes :type-params type-params :type-args (mapcar #'ensure-cpp-type type-args)))) (defmethod print-object ((cpp-type cpp-type) stream) (print-unreadable-object (cpp-type stream :type t) (format stream "~A" (cpp-type-decl cpp-type)))) (defun cpp-type= (a b) (check-type a cpp-type) (check-type b cpp-type) "Test whether two instances of CPP-TYPE, A and B, represent the same C++ type. For the test to return true, the following must hold: - The CPP-TYPE-NAME of A and B must be STRING=. - The CPP-TYPE-NAMESPACE of A and B must be EQUAL. - The CPP-TYPE-ENCLOSING-CLASSES of A and B must be EQUAL. - The CPP-TYPE-TYPE-PARAMS of A and B must be pairwise STRING=. - The CPP-TYPE-TYPE-ARGS of A and B must be pairwise CPP-TYPE=." (and (string= (cpp-type-name a) (cpp-type-name b)) (equal (cpp-type-namespace a) (cpp-type-namespace b)) (equal (cpp-type-enclosing-classes a) (cpp-type-enclosing-classes b)) (not (mismatch (cpp-type-type-params a) (cpp-type-type-params b) :test #'string=)) (not (mismatch (cpp-type-type-args a) (cpp-type-type-args b) :test #'cpp-type=)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Unsupported C++ types (defclass unsupported-cpp-type () ((typestring :type string :initarg :typestring :initform nil :reader unsupported-cpp-type-typestring :documentation "The typestring for this type that LCP couldn't parse (doesn't support).")) (:documentation "A class that represents unsupported C++ types.")) (defun make-unsupported-cpp-type (typestring) (make-instance 'unsupported-cpp-type :typestring typestring)) (defmethod print-object ((cpp-type unsupported-cpp-type) stream) (print-unreadable-object (cpp-type stream :type t) (princ (unsupported-cpp-type-typestring cpp-type) stream))) (macrolet ((define-unsupported-cpp-type-methods () (let ((names '(documentation namespace enclosing-classes type-params type-args name))) `(progn ,@(loop :for name :in names :for fname := (alexandria:symbolicate 'cpp-type- name) :collect `(defmethod ,fname ((cpp-type unsupported-cpp-type)) (error ,(format nil "~S doesn't support the method ~S" 'unsupported-cpp-type fname)))))))) (define-unsupported-cpp-type-methods)) (defmethod cpp-type-decl ((cpp-type unsupported-cpp-type) &key &allow-other-keys) "Return the captured typestring for the instance of UNSUPPORTED-CPP-TYPE." (unsupported-cpp-type-typestring cpp-type)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Known C++ enums (defclass cpp-enum (cpp-type) ((values :type list :initarg :values :initform nil :reader cpp-enum-values) ;; If true, generate serialization code for this enum. (serializep :type boolean :initarg :serializep :initform nil :reader cpp-enum-serializep)) (:documentation "Meta information on a C++ enum.")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Known C++ classes (defstruct cpp-member "Meta information on a C++ class (or struct) member variable." ;; The class that contains this member. (name nil :type string :read-only t) (type nil :type (or string general-cpp-type)) (initval nil :type (or null string integer float) :read-only t) (scope :private :type (member :public :protected :private) :read-only t) ;; TODO: Support giving a name for reader function. (reader nil :type boolean :read-only t) (documentation nil :type (or null string) :read-only t) ;; If T, skips this member in serialization code generation. The member may ;; still be deserialized with custom load hook. (dont-save nil :type boolean :read-only t) ;; May be a function which takes 1 argument, member-name. It needs to return ;; C++ code. (slk-save nil :type (or null function) :read-only t) (slk-load nil :type (or null function) :read-only t) (clone t :type (or boolean (eql :copy) function) :read-only t)) (defstruct slk-opts "SLK serialization options for C++ class." ;; BASE is T if the class should be treated as a base class for SLK, even ;; though it may have parents. (base nil :type boolean :read-only t) ;; Extra arguments to the generated save function. List of (name cpp-type). (save-args nil :read-only t) (load-args nil :read-only t) ;; In case of multiple inheritance, pretend we only inherit the 1st base ;; class. (ignore-other-base-classes nil :type boolean :read-only t)) (defstruct clone-opts "Cloning options for C++ class." ;; Extra arguments to the generated clone function. List of (name cpp-type). (args nil :read-only t) (return-type nil :type (or null function) :read-only t) (base nil :read-only t) (ignore-other-base-classes nil :read-only t) (init-object nil :read-only t)) (defstruct type-info-opts "Options for generating TypeInfo of C++ class." (base nil :read-only t) (ignore-other-base-classes nil :read-only t)) (defclass cpp-class (cpp-type) ((structp :type boolean :initarg :structp :initform nil :reader cpp-class-structp) (super-classes :initarg :super-classes :initform nil :accessor %cpp-class-super-classes) (members :initarg :members :initform nil :accessor %cpp-class-members) ;; Custom C++ code in 3 scopes. May be a list of C++ meta information or a ;; single element. (public :initarg :public :initform nil :accessor cpp-class-public) (protected :initarg :protected :initform nil :reader cpp-class-protected) (private :initarg :private :initform nil :accessor cpp-class-private) (slk-opts :type (or null slk-opts) :initarg :slk-opts :initform nil :reader cpp-class-slk-opts) (clone-opts :type (or null clone-opts) :initarg :clone-opts :initform nil :reader cpp-class-clone-opts) (type-info-opts :type type-info-opts :initarg :type-info-opts :initform (make-type-info-opts) :reader cpp-class-type-info-opts) (inner-types :initarg :inner-types :initform nil :reader cpp-class-inner-types) (abstractp :initarg :abstractp :initform nil :reader cpp-class-abstractp)) (:documentation "Meta information on a C++ class (or struct).")) (defmethod cpp-type-decl ((cpp-type cpp-type) &rest kwargs &key (namespacep t) (globalp nil) (enclosing-classes-p t) (type-params-p t)) "Return the C++ type declaration corresponding to the given CPP-TYPE. If NAMESPACEP is true, the namespace (excluding enclosing classes) is included in the declaration. If GLOBALP is true, the namespace (if included) is fully qualified. If ENCLOSING-CLASSES-P is true, the namespace formed by the enclosing classes is included in the declaration. If TYPE-PARAMS-P is true, type parameters are included when CPP-TYPE has type parameters. If CPP-TYPE has type arguments, type arguments are included in the declaration and formatted by recursively calling CPP-TYPE-DECL with the same keyword arguments." (flet ((rec (cpp-type) (apply #'cpp-type-decl cpp-type kwargs))) (with-output-to-string (s) (cond ;; Handle pointers and references specially. ((or (cpp-type-raw-pointer-p cpp-type) (cpp-type-reference-p cpp-type)) (write-string (rec (car (cpp-type-type-args cpp-type))) s) (format s " ~A" (cpp-type-name cpp-type))) (t (when namespacep (when globalp (write-string "::" s)) (write-string (cpp-type-namespace-string cpp-type) s)) (when enclosing-classes-p (write-string (cpp-type-enclosing-classes-string cpp-type) s)) (write-string (cpp-type-name cpp-type) s) (cond ((cpp-type-type-args cpp-type) (format s "<~{~A~^, ~}>" (mapcar #'rec (cpp-type-type-args cpp-type)))) ((and type-params-p (cpp-type-type-params cpp-type)) (format s "<~{~A~^, ~}>" (cpp-type-type-params cpp-type))))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; C++ type parsing (defun parse-cpp-type-declaration (type-decl) "Try to construct a CPP-TYPE instance from the string TYPE-DECL representing a C++ type declaration. The function assumes that TYPE-DECL is a well-formed C++ type declaration. No attempt is made to handle erroneous declarations. Note that the function doesn't aim to support the whole of C++'s type declaration syntax. Certain declarations just aren't supported. If the declaration is successfuly parsed, the resulting CPP-TYPE instance is returned. Otherwise, if the string is empty or if unsupported constructs were used, NIL is returned." (check-type type-decl string) ;; A C++ type declaration for our purposes is of the form: ;; ;; namespace::namespace::type <* or &> ;; |^^^^^^^^^^^^^^^^^^^^| |^^^^^^^^^^^^^^^^^^| |^^^^^| ;; optional optional optional ;; ;; The type arguments are recursively parsed. (when (string= "" type-decl) (return-from parse-cpp-type-declaration nil)) ;; Unsupported: `typename' and array syntax (when (or (search "typename" type-decl) (cl-ppcre:scan "[[\\]]" type-decl)) (return-from parse-cpp-type-declaration nil)) (setf type-decl (string-trim +whitespace-chars+ type-decl)) ;; Check if the type is a primitive type (let ((type-keyword (member type-decl +cpp-primitive-type-names+ :test #'string=))) (when type-keyword (return-from parse-cpp-type-declaration (make-cpp-type (car type-keyword))))) ;; Check if the type is a pointer (let ((ptr-pos (position-if (lambda (c) (or (char= c #\*) (char= c #\&))) type-decl :from-end t))) (when (and ptr-pos (not (cl-ppcre:scan "[()<>]" type-decl :start ptr-pos))) (return-from parse-cpp-type-declaration (let ((type-arg (parse-cpp-type-declaration (subseq type-decl 0 ptr-pos)))) (when type-arg (make-cpp-type (subseq type-decl ptr-pos) :type-args (list type-arg))))))) ;; Other cases (destructuring-bind (full-name &optional template) (cl-ppcre:split "<" type-decl :limit 2) ;; Unsupported: Function or array syntax (let ((pos (if template (position-of-closing-delimiter type-decl #\< #\>) 0))) (when (or (cl-ppcre:scan "[()]" full-name) (cl-ppcre:scan "[()]" type-decl :start (1+ pos))) (return-from parse-cpp-type-declaration nil))) (let* ((parts (cl-ppcre:split "::" full-name)) (name (car (last parts))) (namespace (butlast parts)) (type-args nil)) (when template ;; A class template instantiation ends with the '>' character (let ((arg-start 0)) (cl-ppcre:do-scans (match-start match-end reg-starts reg-ends "[a-zA-Z0-9_:<>() *&]+[,>]" template) (flet ((matchedp (open-char close-char) "Return T if the TEMPLATE[ARG-START:MATCH-END] contains matched OPEN-CHAR and CLOSE-CHAR." (= (count open-char template :start arg-start :end match-end) (count close-char template :start arg-start :end match-end)))) (when (or (= match-end (length template)) ;; We are at the end (and (matchedp #\< #\>) (matchedp #\( #\)))) (let ((type-arg (parse-cpp-type-declaration ;; Take the arg and omit the final [,>] (subseq template arg-start (1- match-end))))) (if type-arg (push type-arg type-args) (return-from parse-cpp-type-declaration nil))) (setf arg-start match-end)))))) ;; Treat the first capitalized namespace and all the ones after that as ;; enclosing classes, whether or not they're known to LCP. (let ((pos (or (position-if (lambda (part) (and (string/= "" part) (upper-case-p (aref part 0)))) namespace) (length namespace)))) (make-cpp-type name :namespace (subseq namespace 0 pos) :enclosing-classes (subseq namespace pos) :type-args (reverse type-args)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Typestrings (defun ensure-typestring (thing) "Return the typestring corresponding to the typestring designator THING. - If THING is a symbol whose name is STRING-EQUAL to an element in +CPP-PRIMITIVE-TYPE-NAMES+, return it. - If THING is any other symbol, return the result of (cpp-name-for-class thing). - If THING is a string, return it." (check-type thing (or symbol string)) (ctypecase thing (symbol (if (member thing +cpp-primitive-type-names+ :test #'string-equal) (string-downcase thing) (cpp-name-for-class thing))) (string thing))) (defun typestring-supported-p (typestring) "Test whether the typestring TYPESTRING would resolve to a supported CPP-TYPE." (and (parse-cpp-type-declaration typestring) t)) (defun typestring-class-template-instantiation-p (typestring) "Return whether the typestring TYPESTRING would resolve to a CPP-TYPE which is a class template instantiation." (and (cl-ppcre:scan "<|>" typestring) t)) (defun typestring-fully-qualified-p (typestring) "Test whether the supported typestring TYPESTRING is fully qualified. If the typestring is unsupported, return NIL." (and (>= (length typestring) 2) (string= "::" typestring :end2 2))) (defun typestring-qualified-p (typestring) "Test whether the supported typestring TYPESTRING is qualified. If the typestring is unsupported, return NIL. Note that the test only checks the topmost type and doesn't recurse into its type arguments." (or ;; NOTE: Checking whether the typestring is fully qualified is not just an ;; optimization. Since PARSE-CPP-TYPE-DECLARATION drops any qualifiers for ;; the global namespace, without this check we wouldn't be able to tell e.g. ;; whether the typestring "::MyClass" is fully qualified or not. (typestring-fully-qualified-p typestring) (let ((cpp-type (parse-cpp-type-declaration typestring))) (and cpp-type (cpp-type-extended-namespace cpp-type) t)))) (define-condition typestring-warning (simple-warning) ()) (defun typestring-warn (control &rest args) (warn 'typestring-warning :format-control control :format-arguments args)) (defun process-typestring (typestring) "Process the typestring TYPESTRING. To process the typestring means to: - Leave it as is if it's fully qualified, unqualified or unsupported. - Fully qualify it if it's partially qualified." (check-type typestring string) (cond ((or (not (typestring-supported-p typestring)) (typestring-fully-qualified-p typestring)) typestring) ((typestring-qualified-p typestring) (let ((cpp-type (parse-cpp-type-declaration typestring))) (unless (string= (first (cpp-type-namespace cpp-type)) "std") (typestring-warn "Treating qualified type \"~A\" as the fully qualified type \"::~A\"." typestring typestring))) (format nil "::~A" typestring)) ;; Unqualified. (t typestring))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Class and Enum Registry (defvar *cpp-classes* nil "List of defined classes from LCP file.") (defvar *cpp-enums* nil "List of defined enums from LCP file.") (defun split-namespace-string (namespace) (let ((parts (cl-ppcre:split "::" namespace))) (if (string= (car parts) "") (cdr parts) parts))) (defun find-cpp-class (name &optional namespace) "Find an instance of CPP-CLASS in the class registry by searching for a specific type. NAME must be either a string, a symbol or a CPP-TYPE instance: - If NAME is a string or a symbol, it is treated as a designator for a class namestring. - If NAME is a CPP-TYPE instance, it is treated as the string produced by (cpp-type-decl name). If the resulting string is qualified, it is split into parts by \"::\", trimming any empty strings on both sides. Every part but the last one is used to form a list of strings that is the namespace, while the last string is used as the name. NAMESPACE is ignored in this case. If the resulting string is not qualified, it is taken to be the name, while the namespace is formed according to the value of NAMESPACE. NAMESPACE can be either a string or a list of strings: - If NAMESPACE is a string, it is treated as the list that's the result of splitting the string by \"::\", trimming any empty strings on both sides. If the string is empty, it designates the empty list. - If NAMESPACE is a list, it must be a list of strings, each naming a single namespace. Finally, the name and the namespace are compared as follows: - The names are compared using STRING=. - The namespaces are compared pairwise using STRING=. The empty list designates the global namespace. Return a CPP-CLASS instance if one is found, otherwise return NIL." (check-type name (or symbol string cpp-type)) (check-type namespace (or nil string list)) (multiple-value-bind (name namespace) (let ((name (ctypecase name ((or symbol string) (ensure-namestring-for-class name)) (cpp-type (cpp-type-decl name))))) (if (typestring-qualified-p name) (let ((parts (split-namespace-string name))) (values (car (last parts)) (butlast parts))) (values name (ctypecase namespace (list namespace) (string (split-namespace-string namespace)))))) (find-if (lambda (cpp-type) (and (string= name (cpp-type-name cpp-type)) (equal namespace (cpp-type-extended-namespace cpp-type)))) *cpp-classes*))) (defun find-cpp-class-ascending (name namespace) "Find an instance of CPP-CLASS in the class registry by searching upwards from the given namespace. The arguments NAME and NAMESPACE work just the same as in FIND-CPP-CLASS, except that: - NAME cannot be a qualified name. - If NAME is a CPP-TYPE instance, then it is treated as the string (cpp-type-name name)." (check-type name (or symbol string cpp-type)) (check-type namespace (or nil string list)) (let ((name (ctypecase name ((or symbol string) (ensure-namestring-for-class name)) (cpp-type (cpp-type-name name)))) (namespace (ctypecase namespace (list namespace) (string (split-namespace-string namespace))))) (when (typestring-qualified-p name) (error "Using the qualified name ~S with ~S" name 'find-cpp-class-ascending)) (let ((cpp-classes (remove-if-not (lambda (cpp-type) (and (string= name (cpp-type-name cpp-type)) (prefix-of-p (cpp-type-extended-namespace cpp-type) namespace :test #'string=))) *cpp-classes*))) (and cpp-classes (minimize cpp-classes :test #'> :key (lambda (cpp-type) (length (cpp-type-extended-namespace cpp-type)))))))) (defun find-cpp-class-descending (name &optional namespace) "Find an instance of CPP-CLASS in the class registry by searching downwards from the given namespace. The arguments NAME and NAMESPACE work just the same as in FIND-CPP-CLASS, except that: - NAME cannot be a qualified name. - If NAME is a CPP-TYPE instance, then it is treated as the string (cpp-type-name name)." (check-type name (or symbol string cpp-type)) (check-type namespace (or nil string list)) (let ((name (ctypecase name ((or symbol string) (ensure-namestring-for-class name)) (cpp-type (cpp-type-name name)))) (namespace (ctypecase namespace (list namespace) (string (split-namespace-string namespace))))) (when (typestring-qualified-p name) (error "Using the qualified name ~S with ~S" name 'find-cpp-class-descending)) (let ((cpp-classes (remove-if-not (lambda (cpp-type) (and (string= name (cpp-type-name cpp-type)) (prefix-of-p namespace (cpp-type-extended-namespace cpp-type) :test #'string=))) *cpp-classes*))) (and cpp-classes (minimize cpp-classes :key (lambda (cpp-type) (length (cpp-type-extended-namespace cpp-type)))))))) (defun find-cpp-enum (name &optional namespace) "Find an instance of CPP-ENUM in the enum registry. NAME must be either a string, a symbol or a CPP-TYPE instance: - If NAME is a string or a symbol, it is treated as a designator for a class namestring. - If NAME is a CPP-TYPE instance, it is treated as the string produced by (cpp-type-decl name). If the resulting string is qualified, it is split into parts by \"::\", trimming any empty strings on both sides. Every part but the last one is used to form a list of strings that is the namespace, while the last string is used as the name. NAMESPACE is ignored in this case. If the resulting string is not qualified, it is taken to be the name, while the namespace is formed according to the value of NAMESPACE. NAMESPACE can be either a string or a list of strings: - If NAMESPACE is a string, it is treated as the list that's the result of splitting the string by \"::\", trimming any empty strings on both sides. If the string is empty, it designates the empty list. - If NAMESPACE is a list, it must be a list of strings, each naming a single namespace. Finally, the name and the namespace are compared as follows: - The names are compared using STRING=. - The namespaces are compared pairwise using STRING=. The empty list designates the global namespace. Return a CPP-CLASS instance if one is found, otherwise return NIL." (check-type name (or symbol string cpp-type)) (check-type namespace (or nil string list)) (multiple-value-bind (name namespace) (let ((name (ctypecase name ((or symbol string) (ensure-namestring-for-class name)) (cpp-type (cpp-type-decl name))))) (if (typestring-qualified-p name) (let ((parts (split-namespace-string name))) (values (car (last parts)) (butlast parts))) (values name (ctypecase namespace (list namespace) (string (split-namespace-string namespace)))))) (find-if (lambda (cpp-type) (and (string= name (cpp-type-name cpp-type)) (equal namespace (cpp-type-extended-namespace cpp-type)))) *cpp-enums* :from-end t))) (defun find-cpp-enum-ascending (name namespace) "Find an instance of CPP-ENUM in the enum registry by searching upwards from the given namespace. The arguments NAME and NAMESPACE work just the same as in FIND-CPP-ENUM, except that: - NAME cannot be a qualified name. - If NAME is a CPP-TYPE instance, then it is treated as the string (cpp-type-name name)." (check-type name (or symbol string cpp-type)) (check-type namespace (or nil string list)) (let ((name (ctypecase name ((or symbol string) (ensure-namestring-for-class name)) (cpp-type (cpp-type-name name)))) (namespace (ctypecase namespace (list namespace) (string (split-namespace-string namespace))))) (when (typestring-qualified-p name) (error "Using the qualified name ~S with ~S" name 'find-cpp-enum-ascending)) (let ((cpp-enums (remove-if-not (lambda (cpp-type) (and (string= name (cpp-type-name cpp-type)) (prefix-of-p (cpp-type-extended-namespace cpp-type) namespace :test #'string=))) *cpp-enums*))) (and cpp-enums (minimize cpp-enums :test #'> :key (lambda (cpp-type) (length (cpp-type-extended-namespace cpp-type)))))))) (defun find-cpp-enum-descending (name &optional namespace) "Find an instance of CPP-ENUM in the enum registry by searching downwards from the given namespace. The arguments NAME and NAMESPACE work just the same as in FIND-CPP-ENUM, except that: - NAME cannot be a qualified name. - If NAME is a CPP-TYPE instance, then it is treated as the string (cpp-type-name name)." (check-type name (or symbol string cpp-type)) (check-type namespace (or nil string list)) (let ((name (ctypecase name (string name) (symbol (cpp-name-for-class name)))) (namespace (ctypecase namespace (list namespace) (string (split-namespace-string namespace))))) (when (typestring-qualified-p name) (error "Using the qualified name ~S with an iterative traversal" name)) (let ((cpp-enums (remove-if-not (lambda (cpp-type) (and (string= name (cpp-type-name cpp-type)) (prefix-of-p namespace (cpp-type-extended-namespace cpp-type) :test #'string=))) *cpp-enums*))) (and cpp-enums (minimize cpp-enums :key (lambda (cpp-type) (length (cpp-type-extended-namespace cpp-type)))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Type queries (defun cpp-enum-p (object) "Test whether OBJECT is an instance of CPP-ENUM." (typep object 'cpp-enum)) (defun cpp-class-p (object) "Test whether OBJECT is an instance of CPP-CLASS." (typep object 'cpp-class)) (defun cpp-type-supported-p (general-cpp-type) "Test whether the given GENERAL-CPP-TYPE instance is a supported type (i.e. not an instance of UNSUPPORTED-CPP-TYPE)." (check-type general-cpp-type general-cpp-type) (not (typep general-cpp-type 'unsupported-cpp-type))) (defun cpp-type-known-p (general-cpp-type) "Test whether the given GENERAL-CPP-TYPE instance is a known type." (check-type general-cpp-type general-cpp-type) (or (cpp-class-p general-cpp-type) (cpp-enum-p general-cpp-type))) (defun cpp-type-primitive-p (cpp-type) "Test whether CPP-TYPE represents a primitive C++ type." (check-type cpp-type cpp-type) (and (null (cpp-type-namespace cpp-type)) (null (cpp-type-enclosing-classes cpp-type)) (null (cpp-type-type-params cpp-type)) (null (cpp-type-type-args cpp-type)) (member (cpp-type-name cpp-type) +cpp-primitive-type-names+ :test #'string=) t)) (defun cpp-type-raw-pointer-p (cpp-type) "Test whether CPP-TYPE represents a raw pointer type." (check-type cpp-type cpp-type) (string= (cpp-type-name cpp-type) "*")) (defun cpp-type-reference-p (cpp-type) "Test whether CPP-TYPE represents a reference type." (check-type cpp-type cpp-type) (string= (cpp-type-name cpp-type) "*")) (defun cpp-type-smart-pointer-p (cpp-type) "Test whether CPP-TYPE represents a smart pointer type." (check-type cpp-type cpp-type) (and (cpp-type-class-template-instantiation-p cpp-type) (member (cpp-type-name cpp-type) '("shared_ptr" "unique_ptr") :test #'string=) t)) (defun cpp-type-pointer-p (cpp-type) "Test whether CPP-TYPE represents either a raw or a smart pointer type." (check-type cpp-type cpp-type) (or (cpp-type-raw-pointer-p cpp-type) (cpp-type-smart-pointer-p cpp-type))) (defun cpp-type-simple-class-p (cpp-type) "Test whether CPP-TYPE represents a simple class (class which is not a class template instantiation)." (check-type cpp-type cpp-type) (and (not (cpp-type-primitive-p cpp-type)) (not (cpp-type-type-params cpp-type)) (not (cpp-type-type-args cpp-type)))) (defun cpp-type-class-template-p (cpp-type) "Test whether CPP-TYPE represents a class template." (check-type cpp-type cpp-type) (and (not (cpp-type-raw-pointer-p cpp-type)) (not (cpp-type-reference-p cpp-type)) (cpp-type-type-params cpp-type) t)) (defun cpp-type-class-template-instantiation-p (cpp-type) "Test whether CPP-TYPE represents a class template instantiation." (check-type cpp-type cpp-type) (and (not (member (cpp-type-name cpp-type) '("*" "&") :test #'string=)) (cpp-type-type-args cpp-type) t)) (defun cpp-type-class-p (cpp-type) "Test whether CPP-TYPE represents either a simple class or a class template instantiation." (check-type cpp-type cpp-type) (or (cpp-type-simple-class-p cpp-type) (cpp-type-class-template-instantiation-p cpp-type))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Resolution (defun resolve-typestring-for-super-class (typestring cpp-class) "Resolve the typestring TYPESTRING for a superclass. CPP-CLASS is the CPP-CLASS instance that subclasss the class named by the typestring and is used to perform proper relative lookup, if any." (flet ((rec (cpp-type) ;; NOTE: This will surely produce the original typestring because ;; we only ever resolve typestrings that are either fully qualified ;; or not qualified at all, both of which are preserved by the ;; declaration parsing process. (resolve-typestring-for-super-class (cpp-type-decl cpp-type :globalp (cpp-type-extended-namespace cpp-type)) cpp-class))) (let* ((cpp-type (parse-cpp-type-declaration typestring)) (resolved (cond ((not cpp-type) (make-unsupported-cpp-type typestring)) ((typestring-fully-qualified-p typestring) (or (find-cpp-class typestring) cpp-type)) (t (or (find-cpp-class-ascending typestring (cpp-type-extended-namespace cpp-class)) cpp-type))))) (prog1 resolved ;; Recursively resolve any type arguments, but only for supported types. (when cpp-type (setf (%cpp-type-type-args resolved) (mapcar #'rec (cpp-type-type-args resolved)))))))) (defun resolve-typestring-for-member (typestring cpp-class) "Resolve the typestring TYPESTRING for the type of a member. CPP-CLASS is a CPP-CLASS instance that contains the CPP-MEMBER and is used in order to perform proper relative lookup, if any." (flet ((rec (cpp-type) (resolve-typestring-for-member ;; NOTE: This will surely produce the original typestring because ;; we only ever resolve typestrings that are either fully ;; qualified or not qualified at all, both of which are preserved ;; by the declaration parsing process. (cpp-type-decl cpp-type :globalp (cpp-type-extended-namespace cpp-type)) cpp-class))) (let* ((cpp-type (parse-cpp-type-declaration typestring)) (resolved (cond ((not cpp-type) (make-unsupported-cpp-type typestring)) ((typestring-fully-qualified-p typestring) (or (find-cpp-class typestring) (find-cpp-enum typestring) cpp-type)) ((cpp-type-primitive-p cpp-type) cpp-type) (t ;; The types of members may be defined within the class ;; itself. (let ((namespace (append (cpp-type-extended-namespace cpp-class) (list (cpp-type-name cpp-class))))) (or (find-cpp-class-ascending typestring namespace) (find-cpp-enum-ascending typestring namespace) cpp-type)))))) (prog1 resolved ;; Recursively resolve any type arguments, but only for supported types. (when cpp-type (setf (%cpp-type-type-args resolved) (mapcar #'rec (cpp-type-type-args resolved)))))))) (defmethod cpp-class-super-classes ((cpp-class cpp-class)) "Return a list of GENERAL-CPP-TYPE instances which are the superclasses of the C++ class CPP-CLASS." (mapcar (lambda (typestring) (resolve-typestring-for-super-class typestring cpp-class)) (%cpp-class-super-classes cpp-class))) (defmethod cpp-class-members (cpp-class) (mapcar (lambda (member) (let ((member (copy-cpp-member member))) (prog1 member (setf (cpp-member-type member) (resolve-typestring-for-member (cpp-member-type member) cpp-class))))) (%cpp-class-members cpp-class))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Type utilities (defun ensure-cpp-type (thing) "Return a CPP-TYPE instance corresponding to the CPP-TYPE designator THING. - If THING is of type CPP-TYPE, return it. - If THING is a typestring designator it is coerced into a typestring as if by ENSURE-TYPESTRING. The typestring is then parsed using PARSE-CPP-TYPE-DECLARATION. If it is successfully parsed, return the resulting CPP-TYPE instance. Otherwise, return an instance of UNSUPPORTED-CPP-TYPE." (ctypecase thing (cpp-type thing) ((or symbol string) (let ((thing (ensure-typestring thing))) (or (parse-cpp-type-declaration thing) (make-unsupported-cpp-type thing)))))) (defun cpp-class-direct-subclasses (cpp-class) "Return a list of CPP-CLASS instances which are the direct subclasses of the C++ class CPP-CLASS." (check-type cpp-class cpp-class) ;; Reverse to get them in definition order. (reverse (remove-if-not (lambda (subclass) (member cpp-class (remove-if-not #'cpp-type-supported-p (cpp-class-super-classes subclass)) :test #'cpp-type=)) *cpp-classes*))) (defun cpp-type-extended-namespace (cpp-type) (check-type cpp-type cpp-type) (append (cpp-type-namespace cpp-type) (cpp-type-enclosing-classes cpp-type))) (defun cpp-type-namespace-string (cpp-type) "Return the namespace part of CPP-TYPE as a string ending with \"::\". When CPP-TYPE has no namespace, return an empty string." (check-type cpp-type cpp-type) (format nil "~{~A::~}" (cpp-type-namespace cpp-type))) (defun cpp-type-enclosing-classes-string (cpp-type) "Return as a string the concatenation of the names of the enclosing classes of the type CPP-TYPE. The names are delimited with \"::\" and a trailing delimiter is included." (check-type cpp-type cpp-type) (format nil "~{~A::~}" (cpp-type-enclosing-classes cpp-type))) (defun cpp-class-members-for-save (cpp-class) (check-type cpp-class cpp-class) (remove-if #'cpp-member-dont-save (cpp-class-members cpp-class))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Macros ;;; ;;; These provide a small DSL for defining enums and classes. The defined enums ;;; and classes are automatically added to the global enum and class registries. ;;; ;;; *CPP-INNER-TYPES* and *CPP-ENCLOSING-CLASSES* are used to communicate (at ;;; run-time, not macroexpansion-time) information between nested usages of the ;;; macros. The expansions are such that any nested expansions will be evaluated ;;; within a dynamic environment set up by the parent macro. (defvar *cpp-inner-types* :toplevel "A list of CPP-TYPE instances defined within the current class being defined.") (defvar *cpp-enclosing-classes* nil "A list of strings naming the enclosing classes of the current class being defined. The names are ordered from outermost to innermost enclosing class.") (defmacro define-enum (name values &rest options) "Define a C++ enum. Documentation is optional. The only options are :documentation and :serialize. Syntax is: ;; (define-enum name ;; (value1 value2 ...) ;; (:enum-option option-value)*)" (check-type name (or symbol string)) (let ((documentation (second (assoc :documentation options))) (enum (gensym (format nil "ENUM-~A" name)))) `(let ((,enum (make-instance 'cpp-enum :documentation ',documentation :name ',(ensure-namestring-for-class name) :values ',(mapcar #'ensure-namestring-for-enumerator values) :namespace (reverse *cpp-namespaces*) :enclosing-classes (reverse *cpp-enclosing-classes*) :serializep ',(if (assoc :serialize options) t)))) (prog1 ,enum (push ,enum *cpp-enums*) (unless (eq *cpp-inner-types* :toplevel) (push ,enum *cpp-inner-types*)))))) (defmacro define-class (name super-classes slots &rest options) "Define a C++ class. Syntax is: ;; (define-class name (list-of-super-classes) ;; ((c++-slot-definition)*) ;; (:class-option option-value)*) Class name may be a list where the first element is the class name, while others are template parameters. For example: ;; (define-class (optional t-value) ;; ...) defines a templated C++ class: template class Optional { ... }; Each C++ member/slot definition is of the form: ;; (name cpp-type slot-options) slot-options are keyword arguments. Currently supported options are: * :initval -- initializer value for the member, a C++ string or a number. * :reader -- if t, generates a public getter for the member. * :scope -- class scope of the member, either :public, :protected or :private (default). * :documentation -- Doxygen documentation of the member. Currently supported class-options are: * :documentation -- Doxygen documentation of the class. * :public -- additional C++ code in public scope. * :protected -- additional C++ code in protected scope. * :private -- additional C++ code in private scope. * :serialize -- only (:slk) is supported for now. You may specify additional options additional options after :slk to fill the `SLK-OPTS' slots. * :abstractp -- if t, marks that this class cannot be instantiated (currently only useful in serialization code) Larger example: ;; (lcp:define-class derived (base) ;; ((val :int :reader t :initval 42)) ;; (:public #>cpp void set_val(int new_val) { val_ = new_val; } cpp<#) ;; (:serialize (:slk))) Generates C++: ;; class Derived : public Base { ;; public: ;; void set_val(int new_val) { val_ = new_val; } ;; auto val() { return val_; } // autogenerated from :reader t ;; ;; void Save(capnp::Base::Builder *builder) const; ;; static std::unique_ptr Construct(const capnp::Base::Reader &reader); ;; void Load(const capnp::Base::Reader &reader); ;; ;; private: ;; int val_ = 42; // :initval is assigned ;; };" (let ((structp (second (assoc :structp options)))) (flet ((parse-slot (slot-name type &rest kwargs &key reader scope &allow-other-keys) (let ((scope (if scope scope (if structp :public :private)))) (when (and structp reader (eq :private scope)) (error "Slot ~A is declared private with reader in a struct. You should use define-class" slot-name)) (when (and structp reader (eq :public scope)) (error "Slot ~A is public, you shouldn't specify :reader" slot-name)) `(make-cpp-member :name ',(ensure-namestring-for-member slot-name :structp structp) :type (process-typestring (ensure-typestring ',type)) :scope ',scope ,@kwargs)))) (let* ((name (alexandria:ensure-list name)) (class-name (ensure-namestring-for-class (car name))) (type-params (mapcar #'ensure-namestring-for-type-param (cdr name))) (class (gensym (format nil "CLASS-~A" class-name))) (serialize (cdr (assoc :serialize options))) (abstractp (second (assoc :abstractp options))) (members (mapcar (lambda (s) (apply #'parse-slot s)) slots))) `(let ((,class (let ((*cpp-inner-types* '()) (*cpp-enclosing-classes* (cons ',class-name *cpp-enclosing-classes*))) (make-instance 'cpp-class :name ,class-name :type-params ',type-params :structp ,(second (assoc :structp options)) :documentation ',(second (assoc :documentation options)) :public (list ,@(cdr (assoc :public options))) :protected (list ,@(cdr (assoc :protected options))) :private (list ,@(cdr (assoc :private options))) :slk-opts ,(when (assoc :slk serialize) `(make-slk-opts ,@(cdr (assoc :slk serialize)))) :clone-opts ,(when (assoc :clone options) `(make-clone-opts ,@(cdr (assoc :clone options)))) :type-info-opts (make-type-info-opts ,@(when (assoc :type-info options) (cdr (assoc :type-info options)))) :abstractp ',abstractp :namespace (reverse *cpp-namespaces*) ;; Set the inner types at the end. This works because CL ;; specifies the order of evaluation from left to right. :inner-types *cpp-inner-types*)))) (prog1 ,class (push ,class *cpp-classes*) ;; Set the parent's inner types (unless (eq *cpp-inner-types* :toplevel) (push ,class *cpp-inner-types*)) (setf (%cpp-type-enclosing-classes ,class) (reverse *cpp-enclosing-classes*)) (setf (%cpp-class-super-classes ,class) (mapcar (lambda (super-class) (process-typestring (ensure-typestring super-class))) ',super-classes)) (setf (%cpp-class-members ,class) (list ,@members)))))))) (defmacro define-struct (name super-classes slots &rest options) "The same as DEFINE-CLASS, except that a struct is defined instead (by passing T to the :STRUCTP option)." `(define-class ,name ,super-classes ,slots (:structp t) ,@options)) (defun rpc-constructors (class-name members) "Generate C++ code for an RPC's constructors. CLASS-NAME is the name of the class whose constructors to generate. MEMBERS should be a list of members as in DEFINE-RPC. Detailed documentation regarding the constructors and various options can be found within DEFINE-RPC." (let* ((members (remove-if (lambda (member) (let ((initarg (member :initarg member))) (and initarg (null (second initarg))))) members)) (args (mapcar (lambda (member) (list (ensure-typestring (second member)) (ensure-namestring-for-member (first member) :structp t))) members)) (init-list (mapcar (lambda (member) (let ((var (ensure-namestring-for-variable (first member))) (movep (eq :move (second (member :initarg member))))) (list var (if movep (format nil "std::move(~A)" var) var)))) members)) (full-constructor (with-output-to-string (s) (when members (format s "~A ~A(~:{~A ~A~:^, ~}) : ~:{~A(~A)~:^, ~} {}" (if (= (length members) 1) "explicit" "") class-name args init-list))))) #>cpp ${class-name}() {} ${full-constructor} cpp<#)) (defun rpc-save-load (name) "Generate SLK's `Save` and `Load` functions for a request or response RPC structure named by the string NAME." ;; TODO: Replace FIND-CPP-CLASS-DESCENDING. `(let ((class (find-cpp-class-descending ,name))) (unless (lcp.slk::save-extra-args class) (push ,(progn #>cpp static void Save(const ${name} &self, slk::Builder *builder); cpp<#) (cpp-class-public class)) (in-impl ,(progn #>cpp void ${name}::Save(const ${name} &self, slk::Builder *builder) { slk::Save(self, builder); } cpp<#))) (unless (lcp.slk::load-extra-args class) (push ,(progn #>cpp static void Load(${name} *self, slk::Reader *reader); cpp<#) (cpp-class-public class)) (in-impl ,(progn #>cpp void ${name}::Load(${name} *self, slk::Reader *reader) { slk::Load(self, reader); } cpp<#))))) (defmacro define-rpc (name &body options) "Define an RPC. Two structures are defined, representing the request and the response for the given RPC. NAME should designate a namestring for a class, which is used to produce the names of the two structures. OPTIONS should be an alist of options. The names of the structures are formed by concatenating the namestring NAME with \"Req\" and \"Res\". The two options :REQUEST and :RESPONSE are mandatory. Their bodies should be similar to the body of DEFINE-STRUCT, i.e. (SLOTS STRUCT-OPTION*). Their bodies will be passed to DEFINE-STRUCT, but with any DEFINE-RPC-specific member and structure options removed. DEFINE-RPC introduces an extra member option :INITARG that is described below. For both structures two constructors are generated: - A default constructor that does no explicit initialization of members. - A user-defined constructor that accepts values and initializes members according to their :INITARG option, in order of appearance. If the :INITARG option is omitted or NIL, the constructor doesn't accept a value for the member and the member is not explicitly initialized. If the :INITARG option is true, the constructor accepts a value for the member and the member is copy-initialized. If the :INITARG option is :MOVE, the constructor accepts a value for the member and the member is move-initialized using `std::move`. If the constructor ends up accepting just one member, it is marked `explicit`. If the constructor ends up accepting no members, it is not generated." (flet ((remove-rpc-options (body) `(,(mapcar (lambda (member) `(,(first member) ,(second member) ,@(alexandria:remove-from-plist (cddr member) :initarg))) (car body)) ,@(cdr body)))) (let* ((name (ensure-namestring-for-class name)) (rpc-name (format nil "~ARpc" name)) (req-name (format nil "~AReq" name)) (res-name (format nil "~ARes" name)) (rpc-decl #>cpp using ${rpc-name} = communication::rpc::RequestResponse<${req-name}, ${res-name}>; cpp<#) (request-body (cdr (assoc :request options))) (response-body (cdr (assoc :response options)))) `(cpp-list (define-struct ,req-name () ,@(remove-rpc-options request-body) (:public ,(rpc-constructors req-name (first request-body))) (:serialize (:slk))) ,(rpc-save-load req-name) (define-struct ,res-name () ,@(remove-rpc-options response-body) (:public ,(rpc-constructors res-name (first response-body))) (:serialize (:slk))) ,(rpc-save-load res-name) ,rpc-decl))))