From 017dec8c0efbe1d4d1ccf1e3fa24d9fc1f9448cf Mon Sep 17 00:00:00 2001 From: Lovro Lugovic Date: Fri, 10 May 2019 13:55:21 +0200 Subject: [PATCH] LCP: Refactor the type representation Summary: # Summary ## Concepts and terminology A **namestring for ** is a Lisp string that names the C++ language element `` (such as a namespace, a variable, a class, etc.). Therefore we have a "namestring for a namespace", a "namestring for a variable", etc. A **designator for a namestring for ** is a Lisp object that denotes a "namestring for ". These are symbols and strings themselves. A **typestring** is a Lisp string that represents a C++ type, i.e. its declaration. A **typestring designator** is a Lisp object that denotes a typestring. A typestring (and the corresponding C++ type) is said to be **supported** if it can be parsed using `parse-cpp-type-declaration`. This concept is important and should form the base of our design because we can't really hope to ever support all of C++'s type declarations. A typestring (and the corresponding C++ type) that is not supported is **unsupported**. A **processed typestring** is a typestring that is either fully qualified or unqualified. A C++ type is said to be **known** if LCP knows extra information about the type, rather than just what kind of type it is, in which namespace it lives, etc. For now, the only known types are those that are defined within LCP itself using `define-class` & co. A C++ type is **unknown** if it is not known. **Typestring resolution** is the process of resolving a (processed) typestring into an instance of `cpp-type` or `unsupported-cpp-type`. **Resolving accessors** are accessors which perform typestring resolution. ## Changes Explicitly introduce the concept of supported and known types. `cpp-type` models supported types while `unsupported-cpp-type` models unsupported types. Subclasses of `cpp-type` model known types. `general-cpp-type` is either a `cpp-type` or an `unsupported-cpp-type`. Add various type queries. Fix `define-rpc`'s `:initarg` (remove it from the `cpp-member` struct). Introduce namestrings and their designators in `names.lisp`. Introduce typestrings and their designators. Introduce **processed typestrings**. Our DSL's macros (`define-class` & co.) convert all of the given typestrings into processed typestrings because we don't attempt to support partially qualified names and relative name lookup yet. A warning is signalled when a partially qualified name is treated as a fully qualified name. The slots of `cpp-type`, `cpp-class`, `cpp-member` and `cpp-capnp-opts` now store processed typestrings which are lazily resolved into their corresponding C++ types. The only thing that instances of `unsupported-cpp-type` are good for is getting the typestring that was used to construct them. Most of LCP's functions only work with known C++ types, i.e. `cpp-type` instances. The only function so far that works for both of them is `cpp-type-decl`. Since "unsupportedness" is now explicitly part of LCP, client code is expected to manually check whether a returned type is unsupported or not (or face receiving an error otherwise), unless a function is documented to return only `cpp-type` instances. A similar thing goes for "knowness". Client code is expected to manually check whether a returned type is known or not, unless a function is documented to return only (instances of `cpp-type` subclasses) known types. ## TODO Resolution still has to be done for the following slots of the following structures: - `slk-opts` - `save-args` - `load-args` - `clone-opts` - `args` - `return-type` Reviewers: teon.banek, mtomic Reviewed By: teon.banek Subscribers: pullbot Differential Revision: https://phabricator.memgraph.io/D1962 --- src/lisp/CMakeLists.txt | 2 + src/lisp/clone.lisp | 227 +++-- src/lisp/code-gen.lisp | 59 +- src/lisp/lcp.asd | 4 +- src/lisp/lcp.lisp | 323 +++---- src/lisp/names.lisp | 193 +++++ src/lisp/slk.lisp | 292 +++---- src/lisp/test.lisp | 131 +-- src/lisp/types.lisp | 1487 ++++++++++++++++++++++++-------- src/lisp/util.lisp | 78 ++ src/query/frontend/ast/ast.lcp | 38 +- 11 files changed, 1899 insertions(+), 935 deletions(-) create mode 100644 src/lisp/names.lisp create mode 100644 src/lisp/util.lisp diff --git a/src/lisp/CMakeLists.txt b/src/lisp/CMakeLists.txt index 6c41aa32f..91521081e 100644 --- a/src/lisp/CMakeLists.txt +++ b/src/lisp/CMakeLists.txt @@ -5,6 +5,7 @@ set(lcp_src_files ${CMAKE_SOURCE_DIR}/src/lisp/lcp.asd ${CMAKE_SOURCE_DIR}/src/lisp/lcp-compile ${CMAKE_SOURCE_DIR}/src/lisp/package.lisp + ${CMAKE_SOURCE_DIR}/src/lisp/names.lisp ${CMAKE_SOURCE_DIR}/src/lisp/types.lisp ${CMAKE_SOURCE_DIR}/src/lisp/clone.lisp ${CMAKE_SOURCE_DIR}/src/lisp/code-gen.lisp @@ -54,6 +55,7 @@ macro(define_add_lcp name main_src_files generated_lcp_files) ${CMAKE_SOURCE_DIR}/src/lisp/lcp.asd ${CMAKE_SOURCE_DIR}/src/lisp/lcp-compile ${CMAKE_SOURCE_DIR}/src/lisp/package.lisp + ${CMAKE_SOURCE_DIR}/src/lisp/names.lisp ${CMAKE_SOURCE_DIR}/src/lisp/types.lisp ${CMAKE_SOURCE_DIR}/src/lisp/clone.lisp ${CMAKE_SOURCE_DIR}/src/lisp/code-gen.lisp diff --git a/src/lisp/clone.lisp b/src/lisp/clone.lisp index 15c832d59..0f9e1c1c4 100644 --- a/src/lisp/clone.lisp +++ b/src/lisp/clone.lisp @@ -1,24 +1,5 @@ (in-package #:lcp.clone) -(defvar *variable-idx* 0 "Used to generate unique variable names") - -(defmacro with-vars (vars &body body) - "Generates unique variable names for use in generated code by -appending an index to desired variable names. Useful when generating -loops which might reuse counter names. - -Usage example: - (with-vars ((loop-counter \"i\")) - (format nil \"for (auto ~A = 0; ~A < v.size(); ++~A) { - // do something - }\" - loop-counter loop-counter loop-counter))" - `(let* ((*variable-idx* (1+ *variable-idx*)) - ,@(loop for var in vars collecting - `(,(first var) - (format nil "~A~A" ,(second var) *variable-idx*)))) - ,@body)) - (define-condition clone-error (error) ((message :type string :initarg :message :reader clone-error-message) (format-args :type list :initform nil :initarg :format-args :reader clone-error-format-args)) @@ -31,92 +12,88 @@ Usage example: (error 'clone-error :message message :format-args format-args)) (defun cloning-parent (cpp-class) + (check-type cpp-class lcp::cpp-type) (let ((supers (lcp::cpp-class-super-classes cpp-class)) (opts (lcp::cpp-class-clone-opts cpp-class))) (unless opts - (clone-error "Class ~A isn't cloneable" (lcp::cpp-type-base-name cpp-class))) + (clone-error "Class ~A isn't cloneable" (lcp::cpp-type-name cpp-class))) (cond - ((lcp::clone-opts-base opts) nil) - ((lcp::clone-opts-ignore-other-base-classes opts) (car supers)) + ((lcp::clone-opts-base opts) + nil) + ((lcp::clone-opts-ignore-other-base-classes opts) + (car supers)) (t (when (> (length supers) 1) (clone-error "Cloning doesn't support multiple inheritance (class '~A', parents: '~A')" - (lcp::cpp-type-base-name cpp-class) supers)) + (lcp::cpp-type-name cpp-class) supers)) (car supers))))) (defun cloning-root (cpp-class) + (check-type cpp-class lcp::cpp-type) (let ((parent-class (cloning-parent cpp-class))) (if parent-class - (cloning-root (lcp::find-cpp-class parent-class)) + (cloning-root parent-class) cpp-class))) (defun members-for-cloning (cpp-class) - (do ((current-class cpp-class) members) - ((not current-class) members) - (setf members (append (remove-if-not #'lcp::cpp-member-clone - (lcp::cpp-class-members current-class)) - members)) - (setf current-class (lcp::find-cpp-class (cloning-parent current-class))))) + (check-type cpp-class lcp::cpp-type) + (alexandria:flatten + (reverse + (loop :for current := cpp-class :then (cloning-parent current) + :while current + :collect (remove-if-not #'lcp::cpp-member-clone + (lcp::cpp-class-members current)))))) (defun copy-object (source-name dest-name) (format nil "~A = ~A;" dest-name source-name)) -;; TODO: This could be a common function in types.lisp if it were improved -;; a bit. It probably won't be necessary once we refactor LCP to use uniform -;; type designators. -(defun get-type (type-designator) - (ctypecase type-designator - (lcp::cpp-type type-designator) - (string (lcp::parse-cpp-type-declaration type-designator)) - (symbol (lcp::cpp-type type-designator)))) - (defun clone-by-copy-p (object-type) - (let ((object-type (get-type object-type))) - (cond - ((string= "vector" (lcp::cpp-type-name object-type)) - (clone-by-copy-p (car (lcp::cpp-type-type-args object-type)))) - ((string= "optional" (lcp::cpp-type-name object-type)) - (clone-by-copy-p (car (lcp::cpp-type-type-args object-type)))) - ((string= "unordered_map" (lcp::cpp-type-name object-type)) - (and (clone-by-copy-p (first (lcp::cpp-type-type-args object-type))) - (clone-by-copy-p (second (lcp::cpp-type-type-args object-type))))) - ((string= "pair" (lcp::cpp-type-name object-type)) - (and (clone-by-copy-p (first (lcp::cpp-type-type-args object-type))) - (clone-by-copy-p (second (lcp::cpp-type-type-args object-type))))) - ((lcp::cpp-type-type-args object-type) nil) - ((or (lcp::find-cpp-enum (lcp::cpp-type-name object-type)) - (typep object-type 'lcp::cpp-primitive-type) - (string= "string" (lcp::cpp-type-name object-type)) - ;; TODO: We might want to forbid implicit copying of unknown types once - ;; there's a way to globally mark type as trivially copyable. Now it is - ;; too annoying to add (:clone :copy) option everywhere. - (not (lcp::find-cpp-class (lcp::cpp-type-name object-type)))) - t) - (t - ;; We know now that we're dealing with a C++ class defined in - ;; LCP. A class is cloneable by copy only if it doesn't have - ;; `Clone` function defined, all of its members are cloneable - ;; by copy and it is not a member of inheritance hierarchy. - (let ((cpp-class (lcp::find-cpp-class (lcp::cpp-type-name object-type)))) - (assert cpp-class) - (and (not (lcp::cpp-class-clone-opts cpp-class)) - (not (lcp::direct-subclasses-of cpp-class)) - (not (lcp::cpp-class-super-classes cpp-class)) - (every (lambda (member) - (or (eq (lcp::cpp-member-clone member) :copy) - (clone-by-copy-p (lcp::cpp-member-type member)))) - (lcp::cpp-class-members cpp-class)))))))) + (check-type object-type lcp::cpp-type) + (cond + ((string= "vector" (lcp::cpp-type-name object-type)) + (clone-by-copy-p (car (lcp::cpp-type-type-args object-type)))) + ((string= "optional" (lcp::cpp-type-name object-type)) + (clone-by-copy-p (car (lcp::cpp-type-type-args object-type)))) + ((string= "unordered_map" (lcp::cpp-type-name object-type)) + (and (clone-by-copy-p (first (lcp::cpp-type-type-args object-type))) + (clone-by-copy-p (second (lcp::cpp-type-type-args object-type))))) + ((string= "pair" (lcp::cpp-type-name object-type)) + (and (clone-by-copy-p (first (lcp::cpp-type-type-args object-type))) + (clone-by-copy-p (second (lcp::cpp-type-type-args object-type))))) + ((lcp::cpp-type-type-args object-type) nil) + ((or (lcp::cpp-enum-p object-type) + (lcp::cpp-type-primitive-p object-type) + (string= "string" (lcp::cpp-type-name object-type)) + ;; TODO: We might want to forbid implicit copying of unknown types once + ;; there's a way to globally mark type as trivially copyable. Now it is + ;; too annoying to add (:clone :copy) option everywhere. + (not (lcp::cpp-class-p object-type))) + t) + (t + ;; We know now that we're dealing with a C++ class defined in LCP. A class + ;; is cloneable by copy only if it doesn't have `Clone` function defined, + ;; all of its members are cloneable by copy and it is not a member of a + ;; class hierarchy. + (assert (and (lcp::cpp-type-known-p object-type) + (lcp::cpp-type-class-p object-type))) + (and (not (lcp::cpp-class-clone-opts object-type)) + (not (lcp::cpp-class-direct-subclasses object-type)) + (not (lcp::cpp-class-super-classes object-type)) + (every (lambda (member) + (or (eq (lcp::cpp-member-clone member) :copy) + (clone-by-copy-p (lcp::cpp-member-type member)))) + (lcp::cpp-class-members object-type)))))) (defun clone-object (object-type source-name dest-name &key args) - (let ((object-type (get-type object-type)) - (arg-list (format nil "~{~A~^, ~}" + (check-type object-type lcp::cpp-type) + (let ((arg-list (format nil "~{~A~^, ~}" (mapcar (lambda (name-and-type) - (lcp::cpp-variable-name (first name-and-type))) + (lcp::cpp-name-for-variable (first name-and-type))) args)))) (cond ((clone-by-copy-p object-type) (copy-object source-name dest-name)) - ((lcp::cpp-pointer-type-p object-type) + ((lcp::cpp-type-pointer-p object-type) (format nil "~A = ~A ? ~A->Clone(~A) : nullptr;" dest-name source-name source-name arg-list)) ((string= "optional" (lcp::cpp-type-name object-type)) @@ -128,19 +105,19 @@ Usage example: ((string= "unordered_map" (lcp::cpp-type-name object-type)) (let ((key-type (first (lcp::cpp-type-type-args object-type))) (value-type (second (lcp::cpp-type-type-args object-type)))) - (clone-map key-type value-type source-name dest-name :args args))) + (clone-map key-type value-type source-name dest-name :args args))) ((string= "pair" (lcp::cpp-type-name object-type)) (let ((first-type (first (lcp::cpp-type-type-args object-type))) (second-type (second (lcp::cpp-type-type-args object-type)))) - (clone-pair first-type second-type source-name dest-name :args args))) - ((and (lcp::find-cpp-class (lcp::cpp-type-name object-type)) - (lcp::cpp-class-clone-opts (lcp::find-cpp-class (lcp::cpp-type-name object-type)))) + (clone-pair first-type second-type source-name dest-name :args args))) + ((and (lcp::cpp-class-p object-type) + (lcp::cpp-class-clone-opts object-type)) (format nil "~A = ~A.Clone(~A);" dest-name source-name arg-list)) (t (clone-error "Don't know how to clone object of type ~A" (lcp::cpp-type-decl object-type)))))) (defun clone-vector (elem-type source-name dest-name &key args) - (with-vars ((loop-counter "i")) + (lcp::with-vars ((loop-counter "i")) (format nil "~A.resize(~A.size()); for (auto ~A = 0; ~A < ~A.size(); ++~A) { ~A }" @@ -152,10 +129,11 @@ Usage example: :args args)))) (defun clone-map (key-type value-type source-name dest-name &key args) - (with-vars ((loop-var "kv") (entry-var "entry")) - (let ((entry-type (lcp::make-cpp-type "pair" - :namespace '("std") - :type-args (list key-type value-type)))) + (lcp::with-vars ((loop-var "kv") (entry-var "entry")) + (let ((entry-type (lcp::make-cpp-type + "pair" + :namespace '("std") + :type-args (list key-type value-type)))) (format nil "for (const auto &~A : ~A) { ~A ~A; @@ -168,7 +146,7 @@ Usage example: dest-name entry-var)))) (defun clone-optional (value-type source-name dest-name &key args) - (with-vars ((value-var "value")) + (lcp::with-vars ((value-var "value")) (format nil "if (~A) { ~A ~A; @@ -187,7 +165,7 @@ Usage example: dest-name))) (defun clone-pair (first-type second-type source-name dest-name &key args) - (with-vars ((first-var "first") (second-var "second")) + (lcp::with-vars ((first-var "first") (second-var "second")) (with-output-to-string (cpp-out) (lcp::with-cpp-block-output (cpp-out) (format cpp-out @@ -211,34 +189,39 @@ Usage example: (defun clone-function-definition-for-class (cpp-class) (check-type cpp-class lcp::cpp-class) - (when (lcp::cpp-type-type-params cpp-class) - (clone-error "Don't know how to clone templated class '~A'" - (lcp::cpp-type-base-name cpp-class))) + (when (lcp::cpp-type-class-template-p cpp-class) + (clone-error "Don't know how to clone class template '~A'" + (lcp::cpp-type-name cpp-class))) (let* ((cloning-root (cloning-root cpp-class)) (root-opts (lcp::cpp-class-clone-opts cloning-root)) - (inheritancep (or (lcp::direct-subclasses-of cpp-class) + (inheritancep (or (lcp::cpp-class-direct-subclasses cpp-class) (cloning-parent cpp-class))) - (return-type (cond - ((lcp::clone-opts-return-type root-opts) - (lcp::cpp-code - (funcall (lcp::clone-opts-return-type root-opts) - (lcp::cpp-type-name cpp-class)))) - (inheritancep (format nil "std::unique_ptr<~A>" - (lcp::cpp-type-name (cloning-root cpp-class)))) - (t (lcp::cpp-type-name cpp-class)))) + (return-type + (cond + ((lcp::clone-opts-return-type root-opts) + (lcp::cpp-code + (funcall (lcp::clone-opts-return-type root-opts) + (lcp::cpp-type-name cpp-class)))) + (inheritancep + (format nil "std::unique_ptr<~A>" + (lcp::cpp-type-name (cloning-root cpp-class)))) + (t + (lcp::cpp-type-name cpp-class)))) (declaration - (lcp::cpp-method-declaration cpp-class "Clone" - :args (lcp::clone-opts-args root-opts) - :returns return-type - :virtual (and inheritancep - (eq cpp-class cloning-root)) - :inline t - :const t - :override (and inheritancep - (not (eq cpp-class cloning-root))) - :delete (lcp::cpp-class-abstractp cpp-class)))) + (lcp::cpp-method-declaration + cpp-class "Clone" + :args (lcp::clone-opts-args root-opts) + :returns return-type + :virtual (and inheritancep + (eq cpp-class cloning-root)) + :inline t + :const t + :override (and inheritancep + (not (eq cpp-class cloning-root))) + :delete (lcp::cpp-class-abstractp cpp-class)))) (if (lcp::cpp-class-abstractp cpp-class) - (return-from clone-function-definition-for-class (format nil "~A;" declaration))) + (return-from clone-function-definition-for-class + (format nil "~A;" declaration))) (with-output-to-string (cpp-out) (lcp::with-cpp-block-output (cpp-out :name declaration :semicolonp nil) (let (object-access) @@ -249,7 +232,7 @@ Usage example: (lcp::cpp-code (funcall (lcp::clone-opts-init-object root-opts) "object" (lcp::cpp-type-name cpp-class))) - cpp-out)) + cpp-out)) (inheritancep (setf object-access "object->") (format cpp-out "~&auto object = std::make_unique<~A>();" @@ -259,17 +242,19 @@ Usage example: (format cpp-out "~&~A object;" (lcp::cpp-type-name cpp-class)))) (dolist (member (members-for-cloning cpp-class)) - (let* ((source (lcp::cpp-member-name member :struct (lcp::cpp-class-structp cpp-class))) + (let* ((source (lcp::cpp-member-name member)) (dest (format nil "~A~A" object-access source))) (cond ((eq (lcp::cpp-member-clone member) :copy) (format cpp-out "~&~A" (copy-object source dest))) ((functionp (lcp::cpp-member-clone member)) (format cpp-out "~&~A" - (lcp::cpp-code (funcall (lcp::cpp-member-clone member) source dest)))) - (t - (format cpp-out "~&~A" - (clone-object (lcp::cpp-member-type member) - source dest - :args (lcp::clone-opts-args root-opts))))))) - (format cpp-out "~&return object;")))))) + (lcp::cpp-code (funcall (lcp::cpp-member-clone member) + source dest)))) + (t + (format cpp-out "~&~A" + (clone-object + (lcp::cpp-member-type member) + source dest + :args (lcp::clone-opts-args root-opts))))))) + (format cpp-out "~&return object;")))))) diff --git a/src/lisp/code-gen.lisp b/src/lisp/code-gen.lisp index d142b6aca..2df2a153f 100644 --- a/src/lisp/code-gen.lisp +++ b/src/lisp/code-gen.lisp @@ -22,8 +22,8 @@ see `CALL-WITH-CPP-BLOCK-OUTPUT' documentation." "Invoke FUN with a function for opening C++ namespaces. The function takes care to write namespaces to OUT without redundantly opening already open namespaces." - (declare (type stream out)) - (declare (type (function (function)) fun)) + (check-type out stream) + (check-type fun function) (let (open-namespaces) (funcall fun (lambda (namespaces) ;; No namespaces is global namespace @@ -32,15 +32,15 @@ namespaces." (declare (ignore to-close)) (format out "~%}"))) ;; Check if we need to open or close namespaces - (loop for namespace in namespaces - with unmatched = open-namespaces do - (if (string= namespace (car unmatched)) - (setf unmatched (cdr unmatched)) - (progn - (dolist (to-close unmatched) - (declare (ignore to-close)) - (format out "~%}")) - (format out "namespace ~A {~2%" namespace)))) + (loop :for namespace :in namespaces + :with unmatched := open-namespaces :do + (if (string= namespace (car unmatched)) + (setf unmatched (cdr unmatched)) + (progn + (dolist (to-close unmatched) + (declare (ignore to-close)) + (format out "~%}")) + (format out "namespace ~A {~2%" namespace)))) (setf open-namespaces namespaces))) ;; Close remaining namespaces (dolist (to-close open-namespaces) @@ -60,25 +60,30 @@ context which binds OPEN-NAMESPACE-FUN function for opening namespaces." (defun cpp-documentation (documentation) "Convert DOCUMENTATION to Doxygen style string." - (declare (type string documentation)) + (check-type documentation string) (format nil "/// ~A" (cl-ppcre:regex-replace-all (string #\Newline) documentation (format nil "~%/// ")))) -(defun cpp-variable-name (symbol) - "Get C++ style name of SYMBOL as a string." - (declare (type (or string symbol) symbol)) - (cl-ppcre:regex-replace-all "-" (string-downcase symbol) "_")) +(defvar *variable-idx* 0 "Used to generate unique variable names") -(defun cpp-enumerator-name (symbol) - "Get C++ style enumerator name of SYMBOL as a string. This is like -`CPP-VARIABLE-NAME' but upcased." - (declare (type (or string symbol) symbol)) - (cl-ppcre:regex-replace-all "-" (string-upcase symbol) "_")) +(defmacro with-vars (vars &body body) + "Generates unique variable names for use in generated code by +appending an index to desired variable names. Useful when generating +loops which might reuse counter names. -(defun cpp-member-name (cpp-member &key struct) - "Get C++ style name of the `CPP-MEMBER' as a string." - (declare (type cpp-member cpp-member) - (type boolean struct)) - (let ((cpp-name (cpp-variable-name (cpp-member-symbol cpp-member)))) - (if struct cpp-name (format nil "~A_" cpp-name)))) +Usage example: + (with-vars ((loop-counter \"i\")) + (format nil \"for (auto ~A = 0; ~A < v.size(); ++~A) { + // do something + }\" + loop-counter loop-counter loop-counter))" + `(let* ((*variable-idx* (1+ *variable-idx*)) + ,@(loop :for var :in vars :collecting + `(,(first var) + (format nil "~A~A" ,(second var) *variable-idx*)))) + ,@body)) + +(defun cpp-member-reader-name (cpp-member) + (check-type cpp-member cpp-member) + (string-right-trim '(#\_) (cpp-member-name cpp-member))) diff --git a/src/lisp/lcp.asd b/src/lisp/lcp.asd index 0bc9e4679..b1c4349f1 100644 --- a/src/lisp/lcp.asd +++ b/src/lisp/lcp.asd @@ -2,10 +2,12 @@ :description "LCP: The Lisp C++ Preprocessor" :version "0.0.1" :author "Teon Banek " - :depends-on ("cl-ppcre" "named-readtables" "swank") + :depends-on ("alexandria" "cl-ppcre" "named-readtables" "swank") :serial t :components ((:file "package") + (:file "util") (:file "reader") + (:file "names") (:file "types") (:file "code-gen") (:file "slk") diff --git a/src/lisp/lcp.lisp b/src/lisp/lcp.lisp index d616bf0a9..1ce67caed 100644 --- a/src/lisp/lcp.lisp +++ b/src/lisp/lcp.lisp @@ -4,69 +4,64 @@ (in-package #:lcp) (named-readtables:in-readtable lcp-syntax) -(defvar +vim-read-only+ "vim: readonly") -(defvar +emacs-read-only+ "-*- buffer-read-only: t; -*-") - (defvar *generating-cpp-impl-p* nil "T if we are currently writing the .cpp file.") -(defun fnv1a64-hash-string (string) - "Produce (UNSIGNED-BYTE 64) hash of the given STRING using FNV-1a algorithm. -See https://en.wikipedia.org/wiki/Fowler_Noll_Vo_hash." - (check-type string string) - (let ((hash 14695981039346656037) ;; offset basis - (prime 1099511628211)) - (declare (type (unsigned-byte 64) hash prime)) - (loop for c across string do - (setf hash (mod (* (boole boole-xor hash (char-code c)) prime) - (expt 2 64) ;; Fit to 64bit - ))) - hash)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; C++ code generation (defun cpp-enum-definition (cpp-enum) "Get C++ style `CPP-ENUM' definition as a string." - (declare (type cpp-enum cpp-enum)) + (check-type cpp-enum cpp-enum) (with-output-to-string (s) (when (cpp-type-documentation cpp-enum) (write-line (cpp-documentation (cpp-type-documentation cpp-enum)) s)) (with-cpp-block-output (s :name (format nil "enum class ~A" (cpp-type-name cpp-enum)) :semicolonp t) - (format s "~{ ~A~^,~%~}~%" (mapcar #'cpp-enumerator-name (cpp-enum-values cpp-enum)))))) + (format s "~{ ~A~^,~%~}~%" (cpp-enum-values cpp-enum))))) -(defun cpp-member-declaration (cpp-member &key struct) +(defun cpp-member-declaration (cpp-member) "Get C++ style `CPP-MEMBER' declaration as a string." - (declare (type cpp-member cpp-member) - (type boolean struct)) - (let ((type-name (cpp-type-name (cpp-member-type cpp-member)))) + (check-type cpp-member cpp-member) + (let ((type-name (cpp-type-decl (cpp-member-type cpp-member)))) (with-output-to-string (s) (when (cpp-member-documentation cpp-member) (write-line (cpp-documentation (cpp-member-documentation cpp-member)) s)) (if (cpp-member-initval cpp-member) - (format s "~A ~A{~A};" type-name - (cpp-member-name cpp-member :struct struct) (cpp-member-initval cpp-member)) - (format s "~A ~A;" type-name (cpp-member-name cpp-member :struct struct)))))) + (format s "~A ~A{~A};" + type-name + (cpp-member-name cpp-member) + (cpp-member-initval cpp-member)) + (format s "~A ~A;" + type-name + (cpp-member-name cpp-member)))))) (defun cpp-member-reader-definition (cpp-member) "Get C++ style `CPP-MEMBER' getter (reader) function." - (declare (type cpp-member cpp-member)) - (if (typep (cpp-member-type cpp-member) 'cpp-primitive-type-keywords) - (format nil "auto ~A() const { return ~A; }" (cpp-member-name cpp-member :struct t) (cpp-member-name cpp-member)) - (format nil "const auto &~A() const { return ~A; }" (cpp-member-name cpp-member :struct t) (cpp-member-name cpp-member)))) + (check-type cpp-member cpp-member) + (if (cpp-type-primitive-p (cpp-member-type cpp-member)) + (format nil "auto ~A() const { return ~A; }" + (cpp-member-reader-name cpp-member) + (cpp-member-name cpp-member)) + (format nil "const auto &~A() const { return ~A; }" + (cpp-member-reader-name cpp-member) + (cpp-member-name cpp-member)))) (defun cpp-template (type-params &optional stream) "Generate C++ template declaration from provided TYPE-PARAMS. If STREAM is NIL, returns a string." - (format stream "template <~{class ~A~^,~^ ~}>" - (mapcar #'cpp-type-name type-params))) + (format stream "template <~{class ~A~^,~^ ~}>" type-params)) (defun type-info-declaration-for-class (cpp-class) - (assert (and (not (cpp-type-type-params cpp-class)) - (not (cpp-type-type-args cpp-class)))) + (assert (cpp-type-simple-class-p cpp-class)) (with-output-to-string (s) (write-line "static const utils::TypeInfo kType;" s) - (let* ((type-info-basep (type-info-opts-base (cpp-class-type-info-opts cpp-class))) - (virtual (if (and (or type-info-basep (not (cpp-class-super-classes cpp-class))) - (direct-subclasses-of cpp-class)) + (let* ((type-info-basep (type-info-opts-base + (cpp-class-type-info-opts cpp-class))) + (virtual (if (and (or type-info-basep + (not (cpp-class-super-classes cpp-class))) + (cpp-class-direct-subclasses cpp-class)) "virtual" "")) (override (if (and (not type-info-basep) @@ -77,64 +72,66 @@ NIL, returns a string." virtual override)))) (defun type-info-definition-for-class (cpp-class) - (assert (and (not (cpp-type-type-params cpp-class)) - (not (cpp-type-type-args cpp-class)))) + (assert (cpp-type-simple-class-p cpp-class)) (with-output-to-string (s) - (let ((super-classes (when (not (type-info-opts-base (cpp-class-type-info-opts cpp-class))) + (let ((super-classes (when (not (type-info-opts-base + (cpp-class-type-info-opts cpp-class))) (cpp-class-super-classes cpp-class)))) - (when (type-info-opts-ignore-other-base-classes (cpp-class-type-info-opts cpp-class)) + (when (type-info-opts-ignore-other-base-classes + (cpp-class-type-info-opts cpp-class)) (setf super-classes (list (first super-classes)))) (when (> (length super-classes) 1) (error "Unable to generate TypeInfo for class '~A' due to multiple inheritance!" - (cpp-type-base-name cpp-class))) - (flet ((get-super-type-info (super) - (let ((super-class (find-cpp-class super))) - (format nil "&~A::kType" - (if super-class - (cpp-type-decl super-class) - (cpp-type-name super)))))) - (format s "const utils::TypeInfo ~A::kType{0x~XULL, \"~A\", ~A};~%" - (if *generating-cpp-impl-p* - (cpp-type-name cpp-class) - ;; Use full type declaration if class definition - ;; isn't inside the .cpp file. - (cpp-type-decl cpp-class)) - ;; Use full type declaration for hash - (fnv1a64-hash-string (cpp-type-decl cpp-class)) - (cpp-type-name cpp-class) - (if super-classes (get-super-type-info (first super-classes)) "nullptr")))))) + (cpp-type-name cpp-class))) + (format s "const utils::TypeInfo ~A::kType{0x~XULL, \"~A\", ~A};~%" + (if *generating-cpp-impl-p* + (cpp-type-name cpp-class) + ;; Use full type declaration if class definition + ;; isn't inside the .cpp file. + (cpp-type-decl cpp-class)) + ;; Use full type declaration for hash + (fnv1a64-hash-string (cpp-type-decl cpp-class)) + (cpp-type-name cpp-class) + (if super-classes + (format nil "&~A::kType" + (cpp-type-decl (first super-classes))) + "nullptr"))))) (defun cpp-class-definition (cpp-class) "Get C++ definition of the CPP-CLASS as a string." - (declare (type cpp-class cpp-class)) + (check-type cpp-class cpp-class) (flet ((cpp-class-members-scoped (scope) (remove-if (lambda (m) (not (eq scope (cpp-member-scope m)))) (cpp-class-members cpp-class))) (member-declaration (member) - (cpp-member-declaration member :struct (cpp-class-structp cpp-class)))) + (cpp-member-declaration member))) (with-output-to-string (s) (terpri s) (when (cpp-type-documentation cpp-class) (write-line (cpp-documentation (cpp-type-documentation cpp-class)) s)) - (when (cpp-type-type-params cpp-class) + (when (cpp-type-class-template-p cpp-class) (cpp-template (cpp-type-type-params cpp-class) s)) (if (cpp-class-structp cpp-class) (write-string "struct " s) (write-string "class " s)) (format s "~A" (cpp-type-name cpp-class)) - (when (cpp-class-super-classes cpp-class) - (format s " : ~{public ~A~^, ~}" - (mapcar #'cpp-type-name (cpp-class-super-classes cpp-class)))) + (let ((super-classes (cpp-class-super-classes cpp-class))) + (when super-classes + (format s " : ~{public ~A~^, ~}" + (mapcar #'cpp-type-decl super-classes)))) (with-cpp-block-output (s :semicolonp t) (let ((reader-members (remove-if (complement #'cpp-member-reader) (cpp-class-members cpp-class)))) - (when (or (cpp-class-public cpp-class) (cpp-class-members-scoped :public) reader-members - ;; We at least have public TypeInfo object for non-template classes. - (not (cpp-type-type-params cpp-class))) + (when (or (cpp-class-public cpp-class) + (cpp-class-members-scoped :public) + reader-members + ;; We at least have public TypeInfo object for non-template + ;; classes. + (not (cpp-type-class-template-p cpp-class))) (unless (cpp-class-structp cpp-class) (write-line " public:" s)) - (unless (cpp-type-type-params cpp-class) - ;; Skip generating TypeInfo for template classes. + ;; Skip generating TypeInfo for class templates. + (unless (cpp-type-class-template-p cpp-class) (write-line (type-info-declaration-for-class cpp-class) s)) (format s "~%~{~A~%~}" (mapcar #'cpp-code (cpp-class-public cpp-class))) (format s "~{~%~A~}~%" (mapcar #'cpp-member-reader-definition reader-members)) @@ -152,9 +149,9 @@ NIL, returns a string." (format s "~{~A~%~}" (mapcar #'cpp-code (cpp-class-private cpp-class))) (format s "~{ ~%~A~}~%" (mapcar #'member-declaration (cpp-class-members-scoped :private))))) - ;; Define the TypeInfo object. Relies on the fact that *CPP-IMPL* is + ;; Define the TypeInfo object. Relies on the fact that *CPP-IMPL* is ;; processed later. - (unless (cpp-type-type-params cpp-class) + (unless (cpp-type-class-template-p cpp-class) (let ((typeinfo-def (type-info-definition-for-class cpp-class))) (if *generating-cpp-impl-p* (write-line typeinfo-def s) @@ -164,13 +161,13 @@ NIL, returns a string." "Generate a C++ top level function declaration named NAME as a string. ARGS is a list of (variable type) function arguments. RETURNS is the return type of the function. TYPE-PARAMS is a list of names for template argments" - (declare (type string name)) - (declare (type string returns)) + (check-type name string) + (check-type returns string) (let ((template (if type-params (cpp-template type-params) "")) (args (format nil "~:{~A ~A~:^, ~}" (mapcar (lambda (name-and-type) - (list (cpp-type-name (second name-and-type)) - (cpp-variable-name (first name-and-type)))) + (list (ensure-typestring (second name-and-type)) + (ensure-namestring-for-variable (first name-and-type)))) args)))) (raw-cpp-string #>cpp @@ -186,19 +183,21 @@ CLASS. ARGS is a list of (variable type) arguments to method. RETURNS is the return type of the function. When INLINE is set to NIL, generates a declaration to be used outside of class definition. Remaining keys are flags which generate the corresponding C++ keywords." - (declare (type cpp-class class) - (type string method-name)) + (check-type class cpp-class) + (check-type method-name string) (let* ((type-params (cpp-type-type-params class)) (template (if (or inline (not type-params)) "" (cpp-template type-params))) (static/virtual (cond ((and inline static) "static") ((and inline virtual) "virtual") (t ""))) - (namespace (if inline "" (format nil "~A::" (cpp-type-decl class :namespace nil)))) + (namespace + (if inline "" (format nil "~A::" (cpp-type-decl + class :namespacep nil)))) (args (format nil "~:{~A ~A~:^, ~}" (mapcar (lambda (name-and-type) - (list (cpp-type-name (second name-and-type)) - (cpp-variable-name (first name-and-type)))) + (list (ensure-typestring (second name-and-type)) + (ensure-namestring-for-variable (first name-and-type)))) args))) (const (if const "const" "")) (override (if (and override inline) "override" "")) @@ -229,22 +228,20 @@ which generate the corresponding C++ keywords." (null "") (otherwise (error "Unknown conversion to C++ for ~S" (type-of cpp))))) -(defun count-newlines (stream &key stop-position) - (loop for pos = (file-position stream) - and char = (read-char stream nil nil) - until (or (not char) (and stop-position (> pos stop-position))) - when (char= #\Newline char) count it)) - +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; +;;; The LCP Driver +(defvar +vim-read-only+ "vim: readonly") +(defvar +emacs-read-only+ "-*- buffer-read-only: t; -*-") (defvar *cpp-namespaces* nil "Stack of C++ namespaces we are generating the code in.") (defmacro namespace (name) "Push the NAME to currently set namespaces." - (declare (type symbol name)) - (let ((cpp-namespace (cpp-variable-name name))) + (check-type name symbol) + (let ((cpp-namespace (cpp-name-for-variable name))) `(progn (push ,cpp-namespace *cpp-namespaces*) (make-raw-cpp @@ -254,8 +251,9 @@ which generate the corresponding C++ keywords." (pop *cpp-namespaces*) #>cpp } cpp<#) -(defvar *cpp-impl* nil "List of (namespace . C++ code) pairs that should be - written in the implementation (.cpp) file.") +(defvar *cpp-impl* nil + "List of (namespace . C++ code) pairs that should be written in the + implementation (.cpp) file.") (defun in-impl (&rest args) (let ((namespaces (reverse *cpp-namespaces*))) @@ -263,139 +261,34 @@ which generate the corresponding C++ keywords." (append *cpp-impl* (mapcar (lambda (cpp) (cons namespaces cpp)) args))))) -(defmacro define-rpc (name request response) - (declare (type list request response)) - (assert (eq :request (car request))) - (assert (eq :response (car response))) - (flet ((decl-type-info (class-name)) - (def-constructor (class-name members) - (let ((full-constructor - (let ((init-members (remove-if (lambda (slot-def) - ;; TODO: proper initarg - (let ((initarg (member :initarg slot-def))) - (and initarg (null (second initarg))))) - members))) - (with-output-to-string (s) - (when init-members - (format s "~A ~A(~:{~A ~A~:^, ~}) : ~:{~A(~A)~:^, ~} {}" - (if (= 1 (list-length init-members)) "explicit" "") - class-name - (mapcar (lambda (member) - (list (cpp-type-name (second member)) - (cpp-variable-name (first member)))) - init-members) - (mapcar (lambda (member) - (let ((var (cpp-variable-name (first member))) - (movep (eq :move (second (member :initarg member))))) - (list var (if movep - (format nil "std::move(~A)" var) - var)))) - init-members))))))) - #>cpp - ${class-name}() {} - ${full-constructor} - cpp<#))) - (let* ((req-sym (intern (format nil "~A-~A" name 'req))) - (req-name (cpp-type-name req-sym)) - (res-sym (intern (format nil "~A-~A" name 'res))) - (res-name (cpp-type-name res-sym)) - (rpc-name (format nil "~ARpc" (cpp-type-name name))) - (rpc-decl - #>cpp - using ${rpc-name} = communication::rpc::RequestResponse<${req-name}, ${res-name}>; - cpp<#)) - `(cpp-list - (define-struct ,req-sym () - ,@(cdr request) - (:public - ,(decl-type-info req-name) - ,(def-constructor req-name (second request))) - (:serialize (:slk))) - (let ((req-class (find-cpp-class ',req-sym))) - (unless (lcp.slk::save-extra-args req-class) - (push ,(progn - #>cpp - static void Save(const ${req-name} &self, slk::Builder *builder); - cpp<#) - (cpp-class-public req-class)) - (in-impl - ,(progn - #>cpp - void ${req-name}::Save(const ${req-name} &self, slk::Builder *builder) { - slk::Save(self, builder); - } - cpp<#))) - (unless (lcp.slk::load-extra-args req-class) - (push ,(progn #>cpp - static void Load(${req-name} *self, slk::Reader *reader); - cpp<#) - (cpp-class-public req-class)) - (in-impl - ,(progn - #>cpp - void ${req-name}::Load(${req-name} *self, slk::Reader *reader) { - slk::Load(self, reader); - } - cpp<#)))) - (define-struct ,res-sym () - ,@(cdr response) - (:public - ,(decl-type-info res-name) - ,(def-constructor res-name (second response))) - (:serialize (:slk))) - (let ((res-class (find-cpp-class ',res-sym))) - (unless (lcp.slk::save-extra-args res-class) - (push ,(progn - #>cpp - static void Save(const ${res-name} &self, slk::Builder *builder); - cpp<#) - (cpp-class-public res-class)) - (in-impl - ,(progn - #>cpp - void ${res-name}::Save(const ${res-name} &self, slk::Builder *builder) { - slk::Save(self, builder); - } - cpp<#))) - (unless (lcp.slk::load-extra-args res-class) - (push ,(progn #>cpp - static void Load(${res-name} *self, slk::Reader *reader); - cpp<#) - (cpp-class-public res-class)) - (in-impl - ,(progn - #>cpp - void ${res-name}::Load(${res-name} *self, slk::Reader *reader) { - slk::Load(self, reader); - } - cpp<#)))) - ,rpc-decl)))) - (defun read-lcp (filepath) - "Read the FILEPATH and return a list of C++ meta information that should be -formatted and output." + "Read the file FILEPATH and return a list of C++ meta information that should +be formatted and output." (with-open-file (in-stream filepath) (let ((*readtable* (named-readtables:find-readtable 'lcp-syntax)) (stream-pos 0)) (handler-case - (loop for form = (read-preserving-whitespace in-stream nil 'eof) - until (eq form 'eof) - for res = (handler-case (eval form) - (error (err) - (file-position in-stream 0) ;; start of stream - (error "~%~A:~A: error:~2%~A~2%in:~2%~A" - (uiop:native-namestring filepath) - (count-newlines in-stream :stop-position (1+ stream-pos)) - err form))) - do (setf stream-pos (file-position in-stream)) - when (typep res '(or raw-cpp cpp-type cpp-list)) - collect res) + (loop :for form := (read-preserving-whitespace in-stream nil 'eof) + :until (eq form 'eof) + :for res := (handler-case (eval form) + (error (err) + ;; Seek to the start of the stream. + (file-position in-stream 0) + (error "~%~A:~A: error:~2%~A~2%in:~2%~A" + (uiop:native-namestring filepath) + (count-newlines + in-stream + :stop-position (1+ stream-pos)) + err form))) + :do (setf stream-pos (file-position in-stream)) + :when (typep res '(or raw-cpp cpp-type cpp-list)) + :collect res) (end-of-file () - (file-position in-stream 0) ;; start of stream + ;; Seek to the start of the stream. + (file-position in-stream 0) (error "~%~A:~A:error: READ error, did you forget a closing ')'?" (uiop:native-namestring filepath) - (count-newlines in-stream - :stop-position (1+ stream-pos)))))))) + (count-newlines in-stream :stop-position (1+ stream-pos)))))))) (defun process-file (lcp-file &key slk-serialize) "Process a LCP-FILE and write the output to .hpp file in the same directory." @@ -443,7 +336,7 @@ formatted and output." (cpp-class (format out "~A;~%" (lcp.slk:save-function-declaration-for-class type-for-slk)) (when (or (cpp-class-super-classes type-for-slk) - (direct-subclasses-of type-for-slk)) + (cpp-class-direct-subclasses type-for-slk)) (format out "~A;~%" (lcp.slk:construct-and-load-function-declaration-for-class type-for-slk))) (unless (cpp-class-abstractp type-for-slk) (format out "~A;~%" (lcp.slk:load-function-declaration-for-class type-for-slk)))) @@ -476,7 +369,7 @@ formatted and output." ;; Top level functions (write-line (lcp.slk:save-function-definition-for-class cpp-type) out) (when (or (cpp-class-super-classes cpp-type) - (direct-subclasses-of cpp-type)) + (cpp-class-direct-subclasses cpp-type)) (format out "~A;~%" (lcp.slk:construct-and-load-function-definition-for-class cpp-type))) (unless (cpp-class-abstractp cpp-type) (write-line (lcp.slk:load-function-definition-for-class cpp-type) out))) diff --git a/src/lisp/names.lisp b/src/lisp/names.lisp new file mode 100644 index 000000000..27381f3ad --- /dev/null +++ b/src/lisp/names.lisp @@ -0,0 +1,193 @@ +(in-package #:lcp) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Name operations on strings + +(defun uppercase-property-resolver (name) + (when (string= name "Uppercase") + #'upper-case-p)) + +(defun string-upcase-first (string) + "Upcase the first letter of the string STRING, if any." + (check-type string string) + (if (string= string "") "" (string-upcase string :end 1))) + +(defun string-downcase-first (string) + "Downcase the first letter of the string STRING, if any." + (check-type string string) + (if (string= string "") "" (string-downcase string :end 1))) + +(defun split-camel-case-string (string) + "Split the camelCase string STRING into a list of parts. The parts are +delimited by uppercase letters." + (check-type string string) + ;; NOTE: We use a custom property resolver which handles the Uppercase + ;; property by forwarding to UPPER-CASE-P. This is so that we avoid pulling + ;; CL-PPCRE-UNICODE & co. + (let ((cl-ppcre:*property-resolver* #'uppercase-property-resolver)) + ;; NOTE: We use an explicit CREATE-SCANNER call in order to avoid issues + ;; with CL-PPCRE's compiler macros which use LOAD-TIME-VALUE which evaluates + ;; its forms within a null lexical environment (so our + ;; CL-PPCRE:*PROPERTY-RESOLVER* binding would not be seen). Edi actually + ;; hints at the problem within the documentation with the sentence "quiz + ;; question - why do we need CREATE-SCANNER here?". :-) + ;; + ;; NOTE: This regex is a zero-width positive lookahead regex. It'll match + ;; any zero-width sequence that is followed by an uppercase letter. + (cl-ppcre:split (cl-ppcre:create-scanner "(?=\\p{Uppercase})") string))) + +(defun split-pascal-case-string (string) + "Split the PascalCase string STRING into a list of parts. The parts are +delimited by uppercase letters." + (check-type string string) + (split-camel-case-string string)) + +(defun split-snake-case-string (string) + "Split the snake_case string STRING into a list of parts. The parts are +delimited by underscores. The underscores are not preserved. Empty parts are +trimmed on both sides." + (check-type string string) + (cl-ppcre:split "_" string)) + +(defun split-kebab-case-string (string) + "Split the kebab-case string STRING into a list of parts. The parts are +delimited by dashes. The dashes are not preserved. Empty parts are trimmed on +both sides." + (check-type string string) + (cl-ppcre:split "-" string)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Name operations on "things" + +(defun split-cased-thing (thing &key from-style) + "Split THING into a list of parts according to its type. + +- If THING is a symbol, it is split using SPLIT-KEBAB-CASE-STRING. + +- If THING is a string, it is split according to the FROM-STYLE keyword + argument. FROM-STYLE can be one of :CAMEL, :PASCAL, :SNAKE or :KEBAB and + denotes splitting using SPLIT-CAMEL-CASE-STRING, SPLIT-PASCAL-CASE-STRING, + SPLIT-SNAKE-CASE-STRING and SPLIT-KEBAB-CASE-STRING respectively. If + FROM-STYLE is omitted or NIL, it is treated as if :CAMEL was given." + (check-type thing (or symbol string)) + (ctypecase thing + (symbol (split-kebab-case-string (string thing))) + (string + (ccase from-style + ((nil :camel :pascal) (split-camel-case-string thing)) + (:snake (split-snake-case-string thing)) + (:kebab (split-kebab-case-string thing)))))) + +(defun camel-case-name (thing &key from-style) + "Return a camelCase string from THING. + +The string is formed according to the parts of THING as returned by +SPLIT-CASED-THING. FROM-STYLE is passed to SPLIT-CASED-THING." + (check-type thing (or symbol string)) + (string-downcase-first + (format nil "~{~A~}" + (mapcar (alexandria:compose #'string-upcase-first #'string-downcase) + (split-cased-thing thing :from-style from-style))))) + +(defun pascal-case-name (thing &key from-style) + "Return a PascalCase string from THING. + +The string is formed according to the parts of THING as returned by +SPLIT-CASED-THING. FROM-STYLE is passed to SPLIT-CASED-THING." + (check-type thing (or symbol string)) + (string-upcase-first (camel-case-name thing :from-style from-style))) + +(defun lower-snake-case-name (thing &key from-style) + "Return a lower_snake_case string from THING. + +The string is formed according to the parts of THING as returned by +SPLIT-CASED-THING. FROM-STYLE is passed to SPLIT-CASED-THING." + (check-type thing (or symbol string)) + (string-downcase + (format nil "~{~A~^_~}" (split-cased-thing thing :from-style from-style)))) + +(defun upper-snake-case-name (thing &key from-style) + "Return a UPPER_SNAKE_CASE string from THING. + +The string is formed according to the parts of THING as returned by +SPLIT-CASED-THING. FROM-STYLE is passed to SPLIT-CASED-THING." + (check-type thing (or symbol string)) + (string-upcase + (format nil "~{~A~^_~}" (split-cased-thing thing :from-style from-style)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Namestrings + +(defun ensure-namestring-for (thing func) + "Return the namestring corresponding to the namestring designator THING. + +- If THING is a symbol, return the result of calling FUNC on its name. + +- If THING is a string, return it." + (check-type thing (or symbol string)) + (ctypecase thing + (symbol (funcall func thing)) + (string thing))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; C++ names and namestrings + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter +cpp-namestring-docstring+ + "Return the ~A namestring corresponding to the ~A namestring designator +THING. + +- If THING is a symbol, return the result of calling ~A on its name. + +- If THING is a string, return it.")) + +(defmacro define-cpp-name (cpp-object name-op) + "Define a name function and a namestring function for the C++ language element +named by the symbol CPP-OBJECT. Both functions rely on the function named by the +symbol NAME-OP to perform the actual operation. + +The name function's name is of the form CPP--NAME. + +The namestring function's name is of the form +ENSURE-NAMESTRING-FOR-." + `(progn + (defun ,(alexandria:symbolicate 'cpp-name-for- cpp-object) + (thing &key from-style) + ,(documentation name-op 'function) + (check-type thing (or symbol string)) + (,name-op thing :from-style from-style)) + (defun ,(alexandria:symbolicate 'ensure-namestring-for- cpp-object) (thing) + ,(format nil +cpp-namestring-docstring+ + (string-downcase cpp-object) + (string-downcase cpp-object) + name-op) + (check-type thing (or symbol string)) + (ensure-namestring-for thing #',name-op)))) + +(define-cpp-name namespace lower-snake-case-name) +(define-cpp-name class pascal-case-name) +(define-cpp-name enum pascal-case-name) +(define-cpp-name type-param pascal-case-name) +(define-cpp-name variable lower-snake-case-name) +(define-cpp-name enumerator upper-snake-case-name) + +(defun cpp-name-for-member (thing &key from-style structp) + "Just like CPP-NAME-FOR-VARIABLE except that the suffix \"_\" is added unless + STRUCTP is true." + (check-type thing (or symbol string)) + (format nil "~A~@[_~]" + (cpp-name-for-variable thing :from-style from-style) + (not structp))) + +(defun ensure-namestring-for-member (thing &key structp) + (check-type thing (or symbol string)) + (ensure-namestring-for + thing (lambda (symbol) (cpp-name-for-member symbol :structp structp)))) + +(setf (documentation 'ensure-namestring-for-member 'function) + (format nil +cpp-namestring-docstring+ + "member" "member" 'cpp-member-name)) diff --git a/src/lisp/slk.lisp b/src/lisp/slk.lisp index 9c13e73d8..a1f19cee5 100644 --- a/src/lisp/slk.lisp +++ b/src/lisp/slk.lisp @@ -1,6 +1,6 @@ -;;;; This file contains code generation for serialization to our Save Load -;;;; Kit (SLK). It works very similarly to Cap'n Proto serialization, but -;;;; without the schema generation. +;;;; This file contains code generation for serialization to our Save Load Kit +;;;; (SLK). It works very similarly to Cap'n Proto serialization, but without +;;;; the schema generation. (in-package #:lcp.slk) @@ -26,94 +26,94 @@ supers)))) (defun save-extra-args (cpp-class) - "Get additional arguments to Save function for CPP-CLASS. Note, returned -extra arguments are of the first class encountered when traversing the -hierarchy from CPP-CLASS to parents." + "Get additional arguments to Save function for CPP-CLASS. Note, returned extra +arguments are of the first class encountered when traversing the hierarchy from +CPP-CLASS to parents." (let ((opts (lcp::cpp-class-slk-opts cpp-class))) (if (and opts (lcp::slk-opts-save-args opts)) (lcp::slk-opts-save-args opts) (let ((parents (cpp-class-super-classes-for-slk cpp-class))) (dolist (parent parents) - (let ((parent-class (lcp::find-cpp-class parent))) - (when parent-class - (return (save-extra-args parent-class))))))))) + (when (lcp::cpp-type-known-p parent) + (return (save-extra-args parent)))))))) (defun load-extra-args (cpp-class) - "Get additional arguments to Load function for CPP-CLASS. Note, returned -extra arguments are of the first class encountered when traversing the -hierarchy from CPP-CLASS to parents." + "Get additional arguments to Load function for CPP-CLASS. Note, returned extra +arguments are of the first class encountered when traversing the hierarchy from +CPP-CLASS to parents." (let ((opts (lcp::cpp-class-slk-opts cpp-class))) (if (and opts (lcp::slk-opts-load-args opts)) (lcp::slk-opts-load-args opts) (let ((parents (cpp-class-super-classes-for-slk cpp-class))) (dolist (parent parents) - (let ((parent-class (lcp::find-cpp-class parent))) - (when parent-class - (return (load-extra-args parent-class))))))))) + (when (lcp::cpp-type-known-p parent) + (return (load-extra-args parent)))))))) (defun save-function-declaration-for-class (cpp-class) - "Generate SLK save function declaration for CPP-CLASS. Note that the code + "Generate SLK save function declaration for CPP-CLASS. Note that the code generation expects the declarations and definitions to be in `slk` namespace." (check-type cpp-class lcp::cpp-class) - (when (lcp::cpp-type-type-params cpp-class) - (slk-error "Don't know how to save templated class '~A'" - (lcp::cpp-type-base-name cpp-class))) - (when (< 1 (list-length (cpp-class-super-classes-for-slk cpp-class))) + (when (lcp::cpp-type-class-template-p cpp-class) + (slk-error "Don't know how to save class template '~A'" + (lcp::cpp-type-name cpp-class))) + (when (> (length (cpp-class-super-classes-for-slk cpp-class)) 1) (slk-error "Don't know how to save multiple parents of '~A'" - (lcp::cpp-type-base-name cpp-class))) + (lcp::cpp-type-name cpp-class))) (let ((self-arg - (list 'self (format nil "const ~A &" - (lcp::cpp-type-decl cpp-class)))) + (list 'self (format nil "const ~A &" + (lcp::cpp-type-decl cpp-class)))) (builder-arg (list 'builder "slk::Builder *"))) (lcp::cpp-function-declaration - "Save" :args (cons self-arg (cons builder-arg (save-extra-args cpp-class))) - :type-params (lcp::cpp-type-type-params cpp-class)))) + "Save" :args (list* self-arg builder-arg (save-extra-args cpp-class)) + :type-params (lcp::cpp-type-type-params cpp-class)))) (defun construct-and-load-function-declaration-for-class (cpp-class) - "Generate SLK construct and load function declaration for CPP-CLASS. This -function needs to be used to load pointers to polymorphic types. Note that -the code generation expects the declarations and definitions to be in `slk` + "Generate SLK construct and load function declaration for CPP-CLASS. This +function needs to be used to load pointers to polymorphic types. Note that the +code generation expects the declarations and definitions to be in `slk` namespace." (check-type cpp-class lcp::cpp-class) - (when (lcp::cpp-type-type-params cpp-class) - (slk-error "Don't know how to load templated class '~A'" - (lcp::cpp-type-base-name cpp-class))) - (when (< 1 (list-length (cpp-class-super-classes-for-slk cpp-class))) + (when (lcp::cpp-type-class-template-p cpp-class) + (slk-error "Don't know how to load class template '~A'" + (lcp::cpp-type-name cpp-class))) + (when (> (length (cpp-class-super-classes-for-slk cpp-class)) 1) (slk-error "Don't know how to load multiple parents of '~A'" - (lcp::cpp-type-base-name cpp-class))) + (lcp::cpp-type-name cpp-class))) (let ((self-arg - (list 'self (format nil "std::unique_ptr<~A> *" (lcp::cpp-type-decl cpp-class)))) + (list 'self (format nil "std::unique_ptr<~A> *" + (lcp::cpp-type-decl cpp-class)))) (reader-arg (list 'reader "slk::Reader *"))) (lcp::cpp-function-declaration - "ConstructAndLoad" :args (cons self-arg (cons reader-arg (load-extra-args cpp-class))) + "ConstructAndLoad" + :args (list* self-arg reader-arg (load-extra-args cpp-class)) :type-params (lcp::cpp-type-type-params cpp-class)))) (defun load-function-declaration-for-class (cpp-class) - "Generate SLK load function declaration for CPP-CLASS. Note that the code + "Generate SLK load function declaration for CPP-CLASS. Note that the code generation expects the declarations and definitions to be in `slk` namespace." (check-type cpp-class lcp::cpp-class) - (when (lcp::cpp-type-type-params cpp-class) - (slk-error "Don't know how to load templated class '~A'" - (lcp::cpp-type-base-name cpp-class))) - (when (< 1 (list-length (cpp-class-super-classes-for-slk cpp-class))) + (when (lcp::cpp-type-class-template-p cpp-class) + (slk-error "Don't know how to load class template '~A'" + (lcp::cpp-type-name cpp-class))) + (when (> (length (cpp-class-super-classes-for-slk cpp-class)) 1) (slk-error "Don't know how to load multiple parents of '~A'" - (lcp::cpp-type-base-name cpp-class))) + (lcp::cpp-type-name cpp-class))) (let ((self-arg - (list 'self (format nil "~A *" (lcp::cpp-type-decl cpp-class)))) + (list 'self (format nil "~A *" (lcp::cpp-type-decl cpp-class)))) (reader-arg (list 'reader "slk::Reader *"))) (lcp::cpp-function-declaration - "Load" :args (cons self-arg (cons reader-arg (load-extra-args cpp-class))) - :type-params (lcp::cpp-type-type-params cpp-class)))) + "Load" :args (list* self-arg reader-arg (load-extra-args cpp-class)) + :type-params (lcp::cpp-type-type-params cpp-class)))) (defun save-members (cpp-class) - "Generate code for saving members of CPP-CLASS. Raise `SLK-ERROR' if the + "Generate code for saving members of CPP-CLASS. Raise `SLK-ERROR' if the serializable member has no public access." (with-output-to-string (s) (dolist (member (lcp::cpp-class-members-for-save cpp-class)) - (let ((member-name (lcp::cpp-member-name member :struct (lcp::cpp-class-structp cpp-class)))) + (let ((member-name (lcp::cpp-member-name member))) (when (not (eq :public (lcp::cpp-member-scope member))) (slk-error "Cannot save non-public member '~A' of '~A'" - (lcp::cpp-member-symbol member) (lcp::cpp-type-base-name cpp-class))) + (lcp::cpp-member-name member) (lcp::cpp-type-name cpp-class))) (cond ((lcp::cpp-member-slk-save member) ;; Custom save function @@ -122,10 +122,10 @@ serializable member has no public access." member-name)) s))) ;; TODO: Maybe support saving (but not loading) unique_ptr. - ((lcp::cpp-pointer-type-p (lcp::cpp-member-type member)) + ((lcp::cpp-type-pointer-p (lcp::cpp-member-type member)) (slk-error "Don't know how to save pointer '~A' in '~A'" - (lcp::cpp-member-type member) - (lcp::cpp-type-base-name cpp-class))) + (lcp::cpp-type-decl (lcp::cpp-member-type member)) + (lcp::cpp-type-name cpp-class))) ;; TODO: Extra args for cpp-class members (t (format s "slk::Save(self.~A, builder);~%" member-name))))))) @@ -137,14 +137,14 @@ serializable member has no public access." (lcp::cpp-class-members cpp-class))) (defun load-members (cpp-class) - "Generate code for loading members of CPP-CLASS. Raise `SLK-ERROR' if the + "Generate code for loading members of CPP-CLASS. Raise `SLK-ERROR' if the serializable member has no public access." (with-output-to-string (s) (dolist (member (members-for-load cpp-class)) - (let ((member-name (lcp::cpp-member-name member :struct (lcp::cpp-class-structp cpp-class)))) + (let ((member-name (lcp::cpp-member-name member))) (when (not (eq :public (lcp::cpp-member-scope member))) (slk-error "Cannot save non-public member '~A' of '~A'" - (lcp::cpp-member-symbol member) (lcp::cpp-type-base-name cpp-class))) + (lcp::cpp-member-name member) (lcp::cpp-type-name cpp-class))) (cond ((lcp::cpp-member-slk-load member) ;; Custom load function @@ -152,89 +152,91 @@ serializable member has no public access." (write-line (lcp::cpp-code (funcall (lcp::cpp-member-slk-load member) member-name)) s))) - ((lcp::cpp-pointer-type-p (lcp::cpp-member-type member)) + ((lcp::cpp-type-pointer-p (lcp::cpp-member-type member)) (slk-error "Don't know how to load pointer '~A' in '~A'" - (lcp::cpp-member-type member) - (lcp::cpp-type-base-name cpp-class))) + (lcp::cpp-type-decl (lcp::cpp-member-type member)) + (lcp::cpp-type-name cpp-class))) ;; TODO: Extra args for cpp-class members (t (format s "slk::Load(&self->~A, reader);~%" member-name))))))) (defun save-parents-recursively (cpp-class) - "Generate code for saving members of all parents, recursively. Raise -`SLK-ERROR' if trying to save templated parent class or if using multiple -inheritance." - (when (< 1 (list-length (cpp-class-super-classes-for-slk cpp-class))) + "Generate code for saving members of all parents, recursively. Raise +`SLK-ERROR' if CPP-CLASS has multiple superclasses or if any ancestor is a class +template." + (when (> (length (cpp-class-super-classes-for-slk cpp-class)) 1) (slk-error "Don't know how to save multiple parents of '~A'" - (lcp::cpp-type-base-name cpp-class))) + (lcp::cpp-type-name cpp-class))) (with-output-to-string (s) (dolist (parent (cpp-class-super-classes-for-slk cpp-class)) - (let ((parent-class (lcp::find-cpp-class parent))) - (cond - ((not parent-class) - (slk-error - "Class '~A' has an unknown parent '~A', serialization is incomplete. Did you forget to mark '~A' as base?" - (lcp::cpp-type-base-name cpp-class) parent (lcp::cpp-type-base-name cpp-class))) - ((lcp::cpp-type-type-params parent-class) - (slk-error "Don't know how to save templated parent class '~A'" - (lcp::cpp-type-base-name parent-class))) - (t - (format s "// Save parent ~A~%" (lcp::cpp-type-name parent)) - (lcp::with-cpp-block-output (s) - (write-string (save-parents-recursively parent-class) s) - (write-string (save-members parent-class) s)))))))) + (cond + ((not (lcp::cpp-type-known-p parent)) + (slk-error + "Class '~A' has an unknown parent '~A', serialization is incomplete. Did you forget to mark '~A' as base?" + (lcp::cpp-type-name cpp-class) + (lcp::cpp-type-name parent) + (lcp::cpp-type-name cpp-class))) + ((lcp::cpp-type-class-template-p parent) + (slk-error "Don't know how to save parent class template '~A'" + (lcp::cpp-type-name parent))) + (t + (format s "// Save parent ~A~%" (lcp::cpp-type-name parent)) + (lcp::with-cpp-block-output (s) + (write-string (save-parents-recursively parent) s) + (write-string (save-members parent) s))))))) (defun load-parents-recursively (cpp-class) - "Generate code for loading members of all parents, recursively. Raise -`SLK-ERROR' if trying to load templated parent class or if using multiple -inheritance." - (when (< 1 (list-length (cpp-class-super-classes-for-slk cpp-class))) + "Generate code for loading members of all parents, recursively. Raise +`SLK-ERROR' if CPP-CLASS has multiple superclasses or if any ancestor is a class +template." + (when (> (length (cpp-class-super-classes-for-slk cpp-class)) 1) (slk-error "Don't know how to load multiple parents of '~A'" - (lcp::cpp-type-base-name cpp-class))) + (lcp::cpp-type-name cpp-class))) (with-output-to-string (s) (dolist (parent (cpp-class-super-classes-for-slk cpp-class)) - (let ((parent-class (lcp::find-cpp-class parent))) - (cond - ((not parent-class) - (slk-error - "Class '~A' has an unknown parent '~A', serialization is incomplete. Did you forget to mark '~A' as base?" - (lcp::cpp-type-base-name cpp-class) parent (lcp::cpp-type-base-name cpp-class))) - ((lcp::cpp-type-type-params parent-class) - (slk-error "Don't know how to load templated parent class '~A'" - (lcp::cpp-type-base-name parent-class))) - (t - (format s "// Load parent ~A~%" (lcp::cpp-type-name parent)) - (lcp::with-cpp-block-output (s) - (write-string (load-parents-recursively parent-class) s) - (write-string (load-members parent-class) s)))))))) + (cond + ((not (lcp::cpp-type-known-p parent)) + (slk-error + "Class '~A' has an unknown parent '~A', serialization is incomplete. Did you forget to mark '~A' as base?" + (lcp::cpp-type-name cpp-class) + (lcp::cpp-type-name parent) + (lcp::cpp-type-name cpp-class))) + ((lcp::cpp-type-type-params parent) + (slk-error "Don't know how to load parent class template '~A'" + (lcp::cpp-type-name parent))) + (t + (format s "// Load parent ~A~%" (lcp::cpp-type-name parent)) + (lcp::with-cpp-block-output (s) + (write-string (load-parents-recursively parent) s) + (write-string (load-members parent) s))))))) (defun forward-save-to-subclasses (cpp-class) "Generate code which forwards the serialization to derived classes of -CPP-CLASS. Raise `SLK-ERROR' if a derived class has template parameters." +CPP-CLASS. Raise `SLK-ERROR' if a derived class has template parameters." (with-output-to-string (s) - (let ((subclasses (lcp::direct-subclasses-of cpp-class))) + (let ((subclasses (lcp::cpp-class-direct-subclasses cpp-class))) (dolist (subclass subclasses) - (when (lcp::cpp-type-type-params subclass) - (slk-error "Don't know how to save derived templated class '~A'" - (lcp::cpp-type-base-name subclass))) + (when (lcp::cpp-type-class-template-p subclass) + (slk-error "Don't know how to save derived class template '~A'" + (lcp::cpp-type-name subclass))) (let ((derived-class (lcp::cpp-type-decl subclass)) - (derived-var (lcp::cpp-variable-name (lcp::cpp-type-base-name subclass))) + (derived-var (lcp::cpp-name-for-variable (lcp::cpp-type-name subclass))) (extra-args (mapcar (lambda (name-and-type) - (lcp::cpp-variable-name (first name-and-type))) + (lcp::cpp-name-for-variable (first name-and-type))) (save-extra-args cpp-class)))) (format s "if (const auto *~A_derived = utils::Downcast(&self)) { return slk::Save(*~A_derived, builder~{, ~A~}); }~%" derived-var derived-class derived-var extra-args)))))) (defun save-function-code-for-class (cpp-class) - "Generate code for serializing CPP-CLASS. Raise `SLK-ERROR' on unsupported -C++ constructs, mostly related to templates." - (when (lcp::cpp-type-type-params cpp-class) - (slk-error "Don't know how to save templated class '~A'" - (lcp::cpp-type-base-name cpp-class))) + "Generate code for serializing CPP-CLASS. Raise `SLK-ERROR' on unsupported C++ +constructs, mostly related to templates." + (when (lcp::cpp-type-class-template-p cpp-class) + (slk-error "Don't know how to save class template '~A'" + (lcp::cpp-type-name cpp-class))) (with-output-to-string (s) (cond - ((lcp::direct-subclasses-of cpp-class) + ((lcp::cpp-class-direct-subclasses cpp-class) ;; We have more derived classes, so forward the call to them. (write-string (forward-save-to-subclasses cpp-class) s) (if (lcp::cpp-class-abstractp cpp-class) @@ -255,16 +257,16 @@ C++ constructs, mostly related to templates." (write-string (save-members cpp-class) s))))) (defun construct-and-load-function-code-for-class (cpp-class) - "Generate code for serializing CPP-CLASS. Raise `SLK-ERROR' on unsupported -C++ constructs, mostly related to templates." + "Generate code for serializing CPP-CLASS. Raise `SLK-ERROR' on unsupported C++ +constructs, mostly related to templates." (assert (or (cpp-class-super-classes-for-slk cpp-class) - (lcp::direct-subclasses-of cpp-class))) - (when (lcp::cpp-type-type-params cpp-class) - (slk-error "Don't know how to load templated class '~A'" - (lcp::cpp-type-base-name cpp-class))) + (lcp::cpp-class-direct-subclasses cpp-class))) + (when (lcp::cpp-type-class-template-p cpp-class) + (slk-error "Don't know how to load class template '~A'" + (lcp::cpp-type-name cpp-class))) (labels ((concrete-subclasses-rec (class) (let ((concrete-classes nil)) - (dolist (subclass (lcp::direct-subclasses-of class) concrete-classes) + (dolist (subclass (lcp::cpp-class-direct-subclasses class) concrete-classes) (unless (lcp::cpp-class-abstractp subclass) (push subclass concrete-classes)) (setf concrete-classes @@ -277,9 +279,9 @@ C++ constructs, mostly related to templates." (push cpp-class concrete-classes)) (dolist (concrete-class concrete-classes) (let ((type-decl (lcp::cpp-type-decl concrete-class)) - (var-name (lcp::cpp-variable-name (lcp::cpp-type-base-name concrete-class))) + (var-name (lcp::cpp-name-for-variable (lcp::cpp-type-name concrete-class))) (extra-args (mapcar (lambda (name-and-type) - (lcp::cpp-variable-name (first name-and-type))) + (lcp::cpp-name-for-variable (first name-and-type))) (load-extra-args cpp-class)))) (lcp::with-cpp-block-output (s :name (format nil "if (~A::kType.id == type_id)" type-decl)) @@ -289,25 +291,25 @@ C++ constructs, mostly related to templates." (write-line "throw slk::SlkDecodeException(\"Trying to load unknown derived type!\");" s))))) (defun load-function-code-for-class (cpp-class) - "Generate code for serializing CPP-CLASS. Raise `SLK-ERROR' on unsupported -C++ constructs, mostly related to templates." - (when (lcp::cpp-type-type-params cpp-class) - (slk-error "Don't know how to load templated class '~A'" - (lcp::cpp-type-base-name cpp-class))) + "Generate code for serializing CPP-CLASS. Raise `SLK-ERROR' on unsupported C++ +constructs, mostly related to templates." + (when (lcp::cpp-type-class-template-p cpp-class) + (slk-error "Don't know how to load class template '~A'" + (lcp::cpp-type-name cpp-class))) (assert (not (lcp::cpp-class-abstractp cpp-class))) (with-output-to-string (s) ;; We are assuming that the generated code is called only in cases when we ;; really have this particular class instantiated and not any of the ;; derived ones. - (when (lcp::direct-subclasses-of cpp-class) + (when (lcp::cpp-class-direct-subclasses cpp-class) (format s "if (self->GetTypeInfo() != ~A::kType)~%" (lcp::cpp-type-decl cpp-class)) (write-line "throw slk::SlkDecodeException(\"Trying to load incorrect derived type!\");" s)) (write-string (load-parents-recursively cpp-class) s) (write-string (load-members cpp-class) s))) (defun save-function-definition-for-class (cpp-class) - "Generate SLK save function. Raise `SLK-ERROR' if an unsupported or invalid -class definition is encountered during code generation. Note that the code + "Generate SLK save function. Raise `SLK-ERROR' if an unsupported or invalid +class definition is encountered during code generation. Note that the code generation expects the declarations and definitions to be in `slk` namespace." (check-type cpp-class lcp::cpp-class) (with-output-to-string (cpp-out) @@ -316,8 +318,8 @@ generation expects the declarations and definitions to be in `slk` namespace." (write-line (save-function-code-for-class cpp-class) cpp-out)))) (defun load-function-definition-for-class (cpp-class) - "Generate SLK load function. Raise `SLK-ERROR' if an unsupported or invalid -class definition is encountered during code generation. Note that the code + "Generate SLK load function. Raise `SLK-ERROR' if an unsupported or invalid +class definition is encountered during code generation. Note that the code generation expects the declarations and definitions to be in `slk` namespace." (check-type cpp-class lcp::cpp-class) (with-output-to-string (cpp-out) @@ -326,9 +328,9 @@ generation expects the declarations and definitions to be in `slk` namespace." (write-line (load-function-code-for-class cpp-class) cpp-out)))) (defun construct-and-load-function-definition-for-class (cpp-class) - "Generate SLK construct and load function. This function needs to be used -to load pointers to polymorphic types. Raise `SLK-ERROR' if an unsupported or -invalid class definition is encountered during code generation. Note that the + "Generate SLK construct and load function. This function needs to be used to +load pointers to polymorphic types. Raise `SLK-ERROR' if an unsupported or +invalid class definition is encountered during code generation. Note that the code generation expects the declarations and definitions to be in `slk` namespace." (check-type cpp-class lcp::cpp-class) @@ -340,7 +342,7 @@ namespace." ;;; CPP-ENUM serialization generation (defun save-function-declaration-for-enum (cpp-enum) - "Generate SLK save function declaration for CPP-ENUM. Note that the code + "Generate SLK save function declaration for CPP-ENUM. Note that the code generation expects the declarations and definitions to be in `slk` namespace." (check-type cpp-enum lcp::cpp-enum) (let ((self-arg @@ -352,16 +354,16 @@ generation expects the declarations and definitions to be in `slk` namespace." (with-output-to-string (s) (write-line "uint8_t enum_value;" s) (lcp::with-cpp-block-output (s :name "switch (self)") - (loop for enum-value in (lcp::cpp-enum-values cpp-enum) - and enum-ix from 0 do - (format s "case ~A::~A: enum_value = ~A; break;" - (lcp::cpp-type-decl cpp-enum) - (lcp::cpp-enumerator-name enum-value) - enum-ix))) + (loop :for enum-value :in (lcp::cpp-enum-values cpp-enum) + :and enum-ix :from 0 :do + (format s "case ~A::~A: enum_value = ~A; break;" + (lcp::cpp-type-decl cpp-enum) + enum-value + enum-ix))) (write-line "slk::Save(enum_value, builder);" s))) (defun save-function-definition-for-enum (cpp-enum) - "Generate SLK save function. Note that the code generation expects the + "Generate SLK save function. Note that the code generation expects the declarations and definitions to be in `slk` namespace." (check-type cpp-enum lcp::cpp-enum) (with-output-to-string (cpp-out) @@ -370,7 +372,7 @@ declarations and definitions to be in `slk` namespace." (write-line (save-function-code-for-enum cpp-enum) cpp-out)))) (defun load-function-declaration-for-enum (cpp-enum) - "Generate SLK load function declaration for CPP-ENUM. Note that the code + "Generate SLK load function declaration for CPP-ENUM. Note that the code generation expects the declarations and definitions to be in `slk` namespace." (check-type cpp-enum lcp::cpp-enum) (let ((self-arg @@ -383,16 +385,16 @@ generation expects the declarations and definitions to be in `slk` namespace." (write-line "uint8_t enum_value;" s) (write-line "slk::Load(&enum_value, reader);" s) (lcp::with-cpp-block-output (s :name "switch (enum_value)") - (loop for enum-value in (lcp::cpp-enum-values cpp-enum) - and enum-ix from 0 do - (format s "case static_cast(~A): *self = ~A::~A; break;" - enum-ix - (lcp::cpp-type-decl cpp-enum) - (lcp::cpp-enumerator-name enum-value))) + (loop :for enum-value :in (lcp::cpp-enum-values cpp-enum) + :and enum-ix :from 0 :do + (format s "case static_cast(~A): *self = ~A::~A; break;" + enum-ix + (lcp::cpp-type-decl cpp-enum) + enum-value)) (write-line "default: throw slk::SlkDecodeException(\"Trying to load unknown enum value!\");" s)))) (defun load-function-definition-for-enum (cpp-enum) - "Generate SLK save function. Note that the code generation expects the + "Generate SLK save function. Note that the code generation expects the declarations and definitions to be in `slk` namespace." (check-type cpp-enum lcp::cpp-enum) (with-output-to-string (cpp-out) diff --git a/src/lisp/test.lisp b/src/lisp/test.lisp index e0264841c..d84b1f10e 100644 --- a/src/lisp/test.lisp +++ b/src/lisp/test.lisp @@ -30,19 +30,33 @@ (in-package #:lcp.test) (defun same-type-test (a b) - "Test whether A and B are the same C++ type under LCP::CPP-TYPE=." - (is a b :test #'lcp::cpp-type=)) + "Test whether two CPP-TYPE designators, A and B, designate CPP-TYPE= CPP-TYPE +instances." + (is (lcp::ensure-cpp-type a) (lcp::ensure-cpp-type b) :test #'lcp::cpp-type=)) + +(defun different-type-test (a b) + "Test whether two CPP-TYPE designators, A and B, designate non-CPP-TYPE= +CPP-TYPE instances." + (isnt (lcp::ensure-cpp-type a) (lcp::ensure-cpp-type b) + :test #'lcp::cpp-type=)) (defun parse-test (type-decl cpp-type) "Test whether TYPE-DECL parses as the C++ type designated by CPP-TYPE." (is (lcp::parse-cpp-type-declaration type-decl) cpp-type :test #'lcp::cpp-type=)) -(defun decl-test (type-decl cpp-type &key (type-params t) (namespace t)) - "Test whether the C++ type designated by CPP-TYPE prints as TYPE-DECL." - (is (lcp::cpp-type-decl cpp-type - :type-params type-params - :namespace namespace) +(defun fail-parse-test (type-decl) + "Test whether TYPE-DECL fails to parse." + (is (lcp::parse-cpp-type-declaration type-decl) nil)) + +(defun decl-test (type-decl cpp-type &key (namespacep t) (type-params-p t)) + "Test whether the C++ type declaration of CPP-TYPE, as produced by +CPP-TYPE-DECL, matches the string TYPE-DECL. + +The keyword arguments NAMESPACEP and TYPE-PARAMS-P are forwarded to +CPP-TYPE-DECL." + (is (lcp::cpp-type-decl cpp-type :type-params-p type-params-p + :namespacep namespacep) type-decl)) (defun different-parse-test (type-decl1 type-decl2) @@ -50,21 +64,28 @@ (lcp::parse-cpp-type-declaration type-decl2) :test #'lcp::cpp-type=)) -(deftest "supported" +(deftest "types" + (subtest "primitive" + (mapc (lambda (name) + (is (string-downcase name) name)) + lcp::+cpp-primitive-type-names+)) (subtest "designators" - (mapc (lambda (sym) - (let ((type (lcp::make-cpp-primitive-type sym))) - (same-type-test sym type) - (same-type-test (string-downcase sym) type) - (same-type-test (string-upcase sym) type) - (same-type-test (string-capitalize sym) type) - (same-type-test (intern (string sym)) type) - (same-type-test (intern (string-downcase sym)) type) - (same-type-test (intern (string-upcase sym)) type) - (same-type-test (intern (string-capitalize sym)) type) - (same-type-test (lcp::make-cpp-primitive-type sym) - type))) - lcp::+cpp-primitive-type-keywords+) + (mapc (lambda (name) + (same-type-test name name) + (same-type-test (string-downcase name) name) + (different-type-test (string-upcase name) name) + (different-type-test (string-capitalize name) name) + (same-type-test (make-symbol (string name)) name) + (same-type-test (make-symbol (string-downcase name)) name) + (same-type-test (make-symbol (string-upcase name)) name) + (same-type-test (make-symbol (string-capitalize name)) name) + (same-type-test + (lcp::make-cpp-type (string-downcase name)) name) + (different-type-test + (lcp::make-cpp-type (string-upcase name)) name) + (different-type-test + (lcp::make-cpp-type (string-capitalize name)) name)) + lcp::+cpp-primitive-type-names+) (mapc (lambda (sym) (let ((type (lcp::make-cpp-type "MyClass"))) (same-type-test sym type))) @@ -78,26 +99,24 @@ (parse-test "char *" (lcp::make-cpp-type "*" :type-args '(:char))) - (parse-test "::std::pair, double>, char>" - (lcp::make-cpp-type - "pair" - :namespace'("" "std") - :type-args - `(,(lcp::make-cpp-type - "MyClass" - :namespace '("my_space") - :type-args - `(,(lcp::make-cpp-type - "function" - :namespace '("std") - :type-args '("void(int, bool)")) - :double)) - :char))) - (parse-test "::my_namespace::EnclosingClass::Thing" - (lcp::make-cpp-type "Thing" - :namespace '("" "my_namespace") - :enclosing-class "EnclosingClass"))) + (lcp::make-cpp-type + "Thing" + :namespace '("" "my_namespace") + :enclosing-classes '("EnclosingClass"))) + + ;; Unsupported constructs + (fail-parse-test + "::std::pair, double>, char>") + (fail-parse-test "char (*)[]") + (fail-parse-test "char (*)[4]") + + ;; We don't handle ordering + (different-parse-test "const char" "char const") + (different-parse-test "volatile char" "char volatile") + (different-parse-test "const volatile char" "char const volatile") + (different-parse-test "const char *" "char const *") + (different-parse-test "volatile char *" "char volatile *")) (subtest "printing" (decl-test "pair" @@ -118,7 +137,7 @@ (decl-test "pair" (lcp::make-cpp-type "pair" :type-params '("TIntegral1" "TIntegral2")) - :type-params nil)) + :type-params-p nil)) (subtest "finding defined enums" (let ((lcp::*cpp-classes* nil) @@ -150,19 +169,7 @@ (ok (not (lcp::find-cpp-enum "my_namespace::NonExistent"))) (ok (not (lcp::find-cpp-enum "::NonExistent")))))) -(deftest "unsupported" - (subtest "cv-qualifiers" - (different-parse-test "const char" "char const") - (different-parse-test "volatile char" "char volatile") - (different-parse-test "const volatile char" "char const volatile") - (different-parse-test "const char *" "char const *") - (different-parse-test "volatile char *" "char volatile *")) - - (subtest "arrays" - (different-parse-test "char (*)[]" "char (*) []") - (different-parse-test "char (*)[4]" "char (*) [4]"))) - -(deftest "fnv-hash" +(deftest "util" (subtest "fnv1a64" (is (lcp::fnv1a64-hash-string "query::plan::LogicalOperator") #xCF6E3316FE845113) @@ -242,7 +249,7 @@ (:serialize (:slk :ignore-other-base-classes t)))) "void Save(const Derived &self, slk::Builder *builder)") (undefine-cpp-types) - ;; Unsupported template classes + ;; Unsupported class templates (is-error (lcp.slk:save-function-declaration-for-class (lcp:define-class (derived t-param) (base) ())) @@ -513,22 +520,22 @@ slk::Load(&self->derived_member, reader); }")) (undefine-cpp-types) - (let ((base-templated-class (lcp:define-struct (base t-param) () + (let ((base-class-template (lcp:define-struct (base t-param) () ((base-member :bool)))) (derived-class (lcp:define-struct derived (base) ((derived-member :int64_t))))) - (is-error (lcp.slk:save-function-definition-for-class base-templated-class) + (is-error (lcp.slk:save-function-definition-for-class base-class-template) 'lcp.slk:slk-error) (is-error (lcp.slk:save-function-definition-for-class derived-class) 'lcp.slk:slk-error)) (undefine-cpp-types) (let ((base-class (lcp:define-struct base () ((base-member :bool)))) - (derived-templated-class (lcp:define-struct (derived t-param) (base) + (derived-class-template (lcp:define-struct (derived t-param) (base) ((derived-member :int64_t))))) (is-error (lcp.slk:save-function-definition-for-class base-class) 'lcp.slk:slk-error) - (is-error (lcp.slk:save-function-definition-for-class derived-templated-class) + (is-error (lcp.slk:save-function-definition-for-class derived-class-template) 'lcp.slk:slk-error)) (undefine-cpp-types) @@ -797,7 +804,7 @@ (:clone)))) (is-error (lcp.clone:clone-function-definition-for-class child-class) 'lcp.clone:clone-error)) - ;; template classes + ;; Class templates (undefine-cpp-types) (let ((container-class (lcp:define-class (my-container t-element) () ((data "TElement *") @@ -962,7 +969,7 @@ (single-member-test (member "std::shared_ptr") "object.member_ = member_ ? member_->Clone() : nullptr;")) (subtest "enum" - (lcp:define-enum enum '(val1 val2 val3)) + (lcp:define-enum enum (val1 val2 val3)) (single-member-test (member "Enum") "object.member_ = member_;")) (subtest "builtin c++ types" @@ -992,5 +999,3 @@ (single-member-test (member "UnknownClass") "object.member_ = member_;") (undefine-cpp-types)))) - - diff --git a/src/lisp/types.lisp b/src/lisp/types.lisp index 5f5260734..e795ce551 100644 --- a/src/lisp/types.lisp +++ b/src/lisp/types.lisp @@ -3,71 +3,218 @@ ;;;; and methods for operating on that data. (in-package #:lcp) +(named-readtables:in-readtable lcp:lcp-syntax) -(deftype cpp-primitive-type-keywords () - "List of keywords that specify a primitive type in C++." - `(member :bool :char :int :int16_t :int32_t :int64_t :uint :uint16_t - :uint32_t :uint64_t :float :double)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Supported and unsupported C++ types -(defvar +cpp-primitive-type-keywords+ - '(:bool :char :int :int16_t :int32_t :int64_t :uint :uint16_t - :uint32_t :uint64_t :float :double)) +(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 :ns :initarg :namespace :initform nil - :reader cpp-type-namespace - :documentation "A list of symbols or strings defining the full - namespace. A single symbol may refer to a `CPP-CLASS' which - encloses this type.") - (enclosing-class :type (or null symbol string) :initarg :enclosing-class - :initform nil :accessor cpp-type-enclosing-class - :documentation "A symbol or a string that is a designator - for the type of the enclosing class of this type, or NIL if - the type has no enclosing class.") - (name :type (or symbol string) :initarg :name :reader cpp-type-base-name - :documentation "Base 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 - :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 + :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.")) -(defclass cpp-primitive-type (cpp-type) - ((name :type cpp-primitive-type-keywords)) - (:documentation "Represents a primitive type in C++.")) +(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) + ((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)) + (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." - (symbol nil :type symbol :read-only t) - (type nil :type (or cpp-primitive-type-keywords string) :read-only t) - (initarg nil :type symbol :read-only t) + ;; 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 + ;; 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. + ;; 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)) @@ -80,7 +227,8 @@ ;; 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. + ;; 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 @@ -98,321 +246,818 @@ (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 - :reader cpp-class-super-classes) - (members :initarg :members :initform nil :reader cpp-class-members) + ((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)) + (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).")) -(defvar *cpp-classes* nil "List of defined classes from LCP file") -(defvar *cpp-enums* nil "List of defined enums from LCP file") +(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. -(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))) +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. -(defun make-cpp-primitive-type (name) - "Create an instance of CPP-PRIMITIVE-TYPE given the arguments." - (check-type name cpp-primitive-type-keywords) - (make-instance 'cpp-primitive-type :name name)) +If ENCLOSING-CLASSES-P is true, the namespace formed by the enclosing classes is +included in the declaration. -(defun make-cpp-type (name &key namespace enclosing-class type-params type-args) - "Create an instance of `CPP-TYPE' given the arguments. Check the -documentation on `CPP-TYPE' members for function arguments." - (check-type name (or symbol string)) - (check-type namespace list) - (check-type enclosing-class (or null symbol string)) - (check-type type-params list) - (check-type type-args list) - (when (and type-params type-args) - (error "A CPP-TYPE can't have both of TYPE-PARAMS and TYPE-ARGS")) - (let ((namespace (if (and namespace - (string= (string-trim +whitespace-chars+ (car namespace)) "")) - (cdr namespace) - namespace))) - (loop for ns in namespace - when (or (find-if (lambda (c) (member c +whitespace-chars+ :test #'char=)) ns) - (string= ns "")) - do (error "Invalid namespace name ~S in ~S" ns namespace)) - (make-instance 'cpp-type - :name name - :namespace namespace - :enclosing-class enclosing-class - :type-params type-params - :type-args (mapcar #'cpp-type type-args)))) +If TYPE-PARAMS-P is true, type parameters are included when CPP-TYPE has type +parameters. -(defun cpp-type= (a b) - (let ((a (cpp-type a)) - (b (cpp-type b))) - (with-accessors ((args1 cpp-type-type-args)) a - (with-accessors ((args2 cpp-type-type-args)) b - (and (equalp (cpp-type-namespace a) (cpp-type-namespace b)) - (equalp (cpp-type-name a) (cpp-type-name b)) - (and (= (length args1) (length args2)) - (every #'cpp-type= args1 args2)) - (string= - (cpp-type-name (cpp-type-enclosing-class a)) - (cpp-type-name (cpp-type-enclosing-class b)))))))) +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))))))))) -(defmethod print-object ((cpp-type cpp-type) stream) - (print-unreadable-object (cpp-type stream :type t) - (with-accessors ((name cpp-type-base-name) - (ns cpp-type-namespace) - (params cpp-type-type-params) - (args cpp-type-type-args)) - cpp-type - (format stream "~a" (cpp-type-decl cpp-type))))) - -(defgeneric cpp-type-name (cpp-type) - (:documentation "Get C++ style type name from `CPP-TYPE' as a string.")) - -(defmethod cpp-type-name ((cpp-type string)) - "Return CPP-TYPE string as is." - cpp-type) - -(defmethod cpp-type-name ((cpp-type cpp-type)) - "Return `CPP-TYPE' name as PascalCase or if string, as is." - (cpp-type-name (cpp-type-base-name cpp-type))) - -(defmethod cpp-type-name ((cpp-type symbol)) - "Return PascalCase of CPP-TYPE symbol or lowercase if it is a primitive type." - (if (typep cpp-type 'cpp-primitive-type-keywords) - (string-downcase cpp-type) - (remove #\- (string-capitalize cpp-type)))) - -(defun cpp-primitive-type-p (type-decl) - "Whether the C++ type designated by TYPE-DECL is a primitive type." - (typep (cpp-type type-decl) 'cpp-primitive-type)) - -(defun cpp-pointer-type-p (type-decl) - "Whether the C++ type designated by TYPE-DECL is a smart or raw pointer type." - (check-type type-decl (or lcp::cpp-type string lcp::cpp-primitive-type-keywords)) - (typecase type-decl - (string (cpp-pointer-type-p (lcp::parse-cpp-type-declaration type-decl))) - (lcp::cpp-type - (or - (string= "*" (lcp::cpp-type-name type-decl)) - (string= "shared_ptr" (lcp::cpp-type-name type-decl)) - (string= "unique_ptr" (lcp::cpp-type-name type-decl)))))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; C++ type parsing (defun parse-cpp-type-declaration (type-decl) - "Parse C++ type from TYPE-DECL string and return CPP-TYPE. + "Try to construct a CPP-TYPE instance from the string TYPE-DECL representing a +C++ type declaration. -For example: +The function assumes that TYPE-DECL is a well-formed C++ type declaration. No +attempt is made to handle erroneous declarations. -::std::pair, double>, char> +Note that the function doesn't aim to support the whole of C++'s type +declaration syntax. Certain declarations just aren't supported. -produces: - -;; (cpp-type -;; :name pair -;; :type-args ((cpp-type -;; :name MyClass -;; :type-args ((cpp-type :name function -;; :type-args (cpp-type :name void(int, bool))) -;; (cpp-type :name double))) -;; (cpp-type :name char)))" +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) - ;; C++ type can be declared as follows: - ;; namespace::namespace::type * - ;; |^^^^^^^^^^^^^^^^^^^^| |^^^^^^^^^^^^^^^^^^| | optional - ;; optional optional - ;; type-args in template are recursively parsed - ;; C++ may contain dependent names with 'typename' keyword, these aren't - ;; supported here. - (when (search "typename" type-decl) - (error "'typename' not supported in '~A'" type-decl)) - (when (find #\& type-decl) - (error "References not supported in '~A'" type-decl)) + ;; 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 primitive type - (let ((type-keyword (member type-decl +cpp-primitive-type-keywords+ - :test #'string-equal))) + ;; 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-instance 'cpp-primitive-type :name (string-downcase - (car type-keyword)))))) - ;; Check if pointer - (let ((ptr-pos (position #\* type-decl :from-end t))) + (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 - (make-cpp-type (subseq type-decl ptr-pos) - :type-args (list (parse-cpp-type-declaration - (subseq type-decl 0 ptr-pos))))))) + (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) - (let* ((namespace-split (cl-ppcre:split "::" full-name)) - (name (car (last namespace-split))) - type-args) + ;; 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 - ;; template ends with '>' character + ;; 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) + "[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 + (when (or (= match-end (length template)) ;; We are at the end (and (matchedp #\< #\>) (matchedp #\( #\)))) - (push (parse-cpp-type-declaration - ;; take the arg and omit final [,>] - (subseq template arg-start (1- match-end))) - type-args) - (setf arg-start (1+ match-end))))))) - (let (namespace enclosing-class namespace-done-p) - (when (cdr namespace-split) - (dolist (ns (butlast namespace-split)) - ;; Treat capitalized namespace as designating an enclosing class. - ;; Only the final enclosing class is taken, because we assume that - ;; we can get enclosing classes recursively via `FIND-CPP-CLASS'. - ;; This won't work if the classes are not defined in LCP. - (cond - ((and (string/= "" ns) (upper-case-p (aref ns 0))) - (setf namespace-done-p t) - (setf enclosing-class ns)) - ((not namespace-done-p) - (push ns namespace)))) - (setf namespace (reverse namespace))) + (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 namespace - :enclosing-class enclosing-class + :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) + (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 + "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))) -;; TODO: use CPP-TYPE, CPP-TYPE= and CPP-PRIMITIVE-TYPE-P in the rest of the -;; code -(defun cpp-type (type-designator) - "Coerce the CPP-TYPE designator TYPE-DESIGNATOR into a CPP-TYPE instance. - -- If TYPE-DESIGNATOR is an instance of CPP-TYPE, CPP-PRIMITIVE-TYPE or - CPP-CLASS, just return it. - -- If TYPE-DESIGNATOR is one of the keywords in +CPP-PRIMITIVE-TYPE-KEYWORDS+, - return an instance of CPP-PRIMITIVE-TYPE with the name being the result - of (string-downcase type-designator). - -- If TYPE-DESIGNATOR is any other symbol, return an instance of CPP-TYPE with - the name being the result of (remove #\- (string-capitalize type-designator)). - -- If TYPE-DESIGNATOR is a string, return an instance of CPP-TYPE with the name - being that string." - (ctypecase type-designator - ((or cpp-type cpp-primitive-type cpp-class) - type-designator) - (cpp-primitive-type-keywords - (make-cpp-primitive-type type-designator)) - ((or symbol string) - (let ((primitive-type - (member type-designator +cpp-primitive-type-keywords+ :test #'string-equal))) - (if primitive-type - (make-cpp-primitive-type (car primitive-type)) - (make-cpp-type - (if (symbolp type-designator) - (remove #\- (string-capitalize type-designator)) - type-designator))))))) - -(defun find-cpp-class (cpp-class-name) - "Find `CPP-CLASS' in *CPP-CLASSES* by CPP-CLASS-NAME" - (check-type cpp-class-name (or symbol string)) - ;; TODO: Find by full name - (if (stringp cpp-class-name) - (find cpp-class-name *cpp-classes* :key #'cpp-type-name :test #'string=) - (find cpp-class-name *cpp-classes* :key #'cpp-type-base-name))) - -(defun find-cpp-enum (cpp-enum-name) - "Find `CPP-ENUM' in *CPP-ENUMS* by CPP-ENUM-NAME" - (check-type cpp-enum-name (or symbol string)) - (if (stringp cpp-enum-name) - (or (find (parse-cpp-type-declaration cpp-enum-name) *cpp-enums* :test #'cpp-type=) - (find cpp-enum-name *cpp-enums* :key #'cpp-type-name :test #'string=)) - (find cpp-enum-name *cpp-enums* :key #'cpp-type-base-name))) - -(defun direct-subclasses-of (cpp-class) - "Find direct subclasses of CPP-CLASS from *CPP-CLASSES*" - (check-type cpp-class (or symbol cpp-class)) - (let ((name (if (symbolp cpp-class) cpp-class (cpp-type-base-name cpp-class)))) - (reverse ;; reverse to get them in definition order - (remove-if (lambda (subclass) - (not (member name (cpp-class-super-classes subclass)))) - *cpp-classes*)))) - -(defun cpp-type-decl (cpp-type &key (type-params t) (namespace t)) - "Return the fully qualified name of given 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) - (flet ((enclosing-classes (cpp-type) - (declare (type cpp-type cpp-type)) - (let ((enclosing '())) - (loop - for class = cpp-type - then (find-cpp-class (cpp-type-enclosing-class class)) - while class - do (push (cpp-type-name class) enclosing)) - enclosing))) - (with-output-to-string (s) - (let ((ptr-pos (position #\* (cpp-type-name cpp-type)))) - (cond - ((and ptr-pos (= 0 ptr-pos)) - ;; Special handle pointer - (write-string (cpp-type-decl (car (cpp-type-type-args cpp-type))) s) - (format s " ~A" (cpp-type-name cpp-type))) - (t - (when namespace - (write-string (cpp-type-namespace-string cpp-type) s)) - (format s "~{~A~^::~}" (enclosing-classes cpp-type)) - (cond - ((cpp-type-type-args cpp-type) - (format s "<~{~A~^, ~}>" (mapcar #'cpp-type-decl - (cpp-type-type-args cpp-type)))) - ((and type-params (cpp-type-type-params cpp-type)) - (format s "<~{~A~^, ~}>" (cpp-type-type-params cpp-type)))))))))) + (format nil "~{~A::~}" (cpp-type-enclosing-classes cpp-type))) -(defvar *cpp-inner-types* nil - "List of cpp types defined inside an enclosing class or struct") +(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))) -(defvar *cpp-enclosing-class* nil - "Symbol name of the `CPP-CLASS' inside which inner types are defined.") +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; 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: +:documentation and :serialize. Syntax is: ;; (define-enum name ;; (value1 value2 ...) ;; (:enum-option option-value)*)" - (declare (type symbol name)) + (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 - :name ',name - :documentation ,documentation - :values ',values - :namespace (reverse *cpp-namespaces*) - :enclosing-class *cpp-enclosing-class* - :serializep ,(if (assoc :serialize options) t)))) + `(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*) - (push ,enum *cpp-inner-types*))))) + (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: @@ -422,7 +1067,7 @@ CPP-TYPE has no namespace, return an empty string." ;; (:class-option option-value)*) Class name may be a list where the first element is the class name, while -others are template arguments. +others are template parameters. For example: @@ -476,49 +1121,205 @@ Generates C++: ;; };" (let ((structp (second (assoc :structp options)))) (flet ((parse-slot (slot-name type &rest kwargs - &key reader scope &allow-other-keys) + &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 :symbol ',slot-name :type ,type :scope ,scope - ,@kwargs)))) - (let ((members (mapcar (lambda (s) (apply #'parse-slot s)) slots)) - (class-name (if (consp name) (car name) name)) - (type-params (when (consp name) (cdr name))) - (class (gensym (format nil "CLASS-~A" name))) - (serialize (cdr (assoc :serialize options))) - (abstractp (second (assoc :abstractp options)))) + `(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* nil) - (*cpp-enclosing-class* ',class-name)) - (make-instance 'cpp-class - :name ',class-name :super-classes ',super-classes - :type-params ',type-params - :structp ,(second (assoc :structp options)) - :members (list ,@members) - :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 inner types at the end. This works - ;; because CL standard specifies order of - ;; evaluation from left to right. - :inner-types *cpp-inner-types*)))) + (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 - (push ,class *cpp-inner-types*) - (setf (cpp-type-enclosing-class ,class) *cpp-enclosing-class*))))))) + (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)))) diff --git a/src/lisp/util.lisp b/src/lisp/util.lisp new file mode 100644 index 000000000..bf14b8031 --- /dev/null +++ b/src/lisp/util.lisp @@ -0,0 +1,78 @@ +(in-package #:lcp) + +(defun fnv1a64-hash-string (string) + "Produce (UNSIGNED-BYTE 64) hash of the given STRING using FNV-1a algorithm. +See https://en.wikipedia.org/wiki/Fowler_Noll_Vo_hash." + (check-type string string) + (let ((hash 14695981039346656037) ; Offset basis + (prime 1099511628211)) + (declare (type (unsigned-byte 64) hash prime)) + (loop :for c :across string :do + (setf hash (mod (* (boole boole-xor hash (char-code c)) prime) + ;; Fit to 64bit + (expt 2 64)))) + hash)) + +(defun count-newlines (stream &key stop-position) + (loop :for pos := (file-position stream) + :and char := (read-char stream nil nil) + :until (or (not char) (and stop-position (> pos stop-position))) + :when (char= #\Newline char) count it)) + +(defun prefix-of-p (prefix seq &key (test #'eql)) + "Test whether the sequence PREFIX is a prefix of the sequence SEQ. The +elements are compared using the 2-element test function TEST. An empty sequence +is considered a prefix of every sequence." + (let ((len1 (length prefix)) + (len2 (length seq))) + (and (<= len1 len2) + (not (mismatch prefix seq :end2 len1 :test test))))) + +(defun minimize (sequence &key (test #'<) key) + "Find the minimum element within the sequence SEQUENCE. + +The minimization is done according to the 2-argument comparison function TEST +which acts as \"strictly less\". If the result of (funcall test a b) is t, then +A is considered to be strictly less than B. + +If KEY is provided, it should be a 1-argument function. When performing a +comparison between 2 elements, the function is applied to each element and the +results are used in place of the original elements." + (reduce + (lambda (a b) + (let ((ka a) + (kb b)) + (when key + (setf ka (funcall key a) + kb (funcall key b))) + (if (funcall test kb ka) b a))) + sequence)) + +(defun position-of-closing-delimiter (str open-char close-char + &key (start 0) end) + "Given a pair of opening and closing delimiters OPEN-CHAR and CLOSE-CHAR, find +within the string STR the position of the closing delimiter that corresponds to +the first occurrence of the opening delimiter. The delimiters may be nested to +an arbitrary depth (and handling such cases is the point of this function). + +Return the position of the found closing delimiter or NIL if one wasn't found." + (let ((len (length str)) + (open-char-pos + (position open-char str :start start :end end))) + (when open-char-pos + (loop :with count := 1 + :for i :from (1+ open-char-pos) :below (or end len) :do + (cond + ((char= (aref str i) open-char) + (incf count)) + ((char= (aref str i) close-char) + (decf count))) + (when (zerop count) + (return i)))))) + +(defmacro muffle-warnings (&body body) + "Execute BODY in a dynamic context where a handler for conditions of type +WARNING has been established. The handler muffles the warning by calling +MUFFLE-WARNING." + `(handler-bind ((warning #'muffle-warning)) + ,@body)) diff --git a/src/query/frontend/ast/ast.lcp b/src/query/frontend/ast/ast.lcp index 49cf13ac5..889faf778 100644 --- a/src/query/frontend/ast/ast.lcp +++ b/src/query/frontend/ast/ast.lcp @@ -370,17 +370,16 @@ cpp<# `(lcp:define-class ,op (binary-operator) () (:public - (let ((cpp-name (lcp::cpp-type-name ',op))) - #>cpp - DEFVISITABLE(ExpressionVisitor); - DEFVISITABLE(ExpressionVisitor); - bool Accept(HierarchicalTreeVisitor &visitor) override { - if (visitor.PreVisit(*this)) { - expression1_->Accept(visitor) && expression2_->Accept(visitor); - } - return visitor.PostVisit(*this); + #>cpp + DEFVISITABLE(ExpressionVisitor); + DEFVISITABLE(ExpressionVisitor); + bool Accept(HierarchicalTreeVisitor &visitor) override { + if (visitor.PreVisit(*this)) { + expression1_->Accept(visitor) && expression2_->Accept(visitor); } - cpp<#)) + return visitor.PostVisit(*this); + } + cpp<#) (:protected #>cpp using BinaryOperator::BinaryOperator; @@ -402,17 +401,16 @@ cpp<# `(lcp:define-class ,op (unary-operator) () (:public - (let ((cpp-name (lcp::cpp-type-name ',op))) - #>cpp - DEFVISITABLE(ExpressionVisitor); - DEFVISITABLE(ExpressionVisitor); - bool Accept(HierarchicalTreeVisitor &visitor) override { - if (visitor.PreVisit(*this)) { - expression_->Accept(visitor); - } - return visitor.PostVisit(*this); + #>cpp + DEFVISITABLE(ExpressionVisitor); + DEFVISITABLE(ExpressionVisitor); + bool Accept(HierarchicalTreeVisitor &visitor) override { + if (visitor.PreVisit(*this)) { + expression_->Accept(visitor); } - cpp<#)) + return visitor.PostVisit(*this); + } + cpp<#) (:protected #>cpp using UnaryOperator::UnaryOperator;