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;