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 <teon.banek@memgraph.io>"
- :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-<CPP-OBJECT>-NAME.
+
+The namestring function's name is of the form
+ENSURE-NAMESTRING-FOR-<CPP-OBJECT>."
+ `(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<const ~A>(&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<uint8_t>(~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<uint8_t>(~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<my_space::MyClass<std::function<void(int, bool)>, 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<my_space::MyClass<std::function<void(int, bool)>, 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<T1, T2>"
@@ -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<Klondike>")
"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 <TValue> 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>`, '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 <TValue> 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>`, `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 "~@<Invalid namespace part ~S in ~S~@:>" part namespace)))
+ (when (and type-params type-args)
+ (error "~@<A CPP-TYPE can't have both of TYPE-PARAMS and TYPE-ARGS~@:>"))
+ (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<my_space::MyClass<std::function<void(int, bool)>, 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<type-arg, type-arg> *
- ;; |^^^^^^^^^^^^^^^^^^^^| |^^^^^^^^^^^^^^^^^^| | 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<type-arg, type-arg> <* 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<TypedValue>);
- DEFVISITABLE(ExpressionVisitor<void>);
- bool Accept(HierarchicalTreeVisitor &visitor) override {
- if (visitor.PreVisit(*this)) {
- expression1_->Accept(visitor) && expression2_->Accept(visitor);
- }
- return visitor.PostVisit(*this);
+ #>cpp
+ DEFVISITABLE(ExpressionVisitor<TypedValue>);
+ DEFVISITABLE(ExpressionVisitor<void>);
+ 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<TypedValue>);
- DEFVISITABLE(ExpressionVisitor<void>);
- bool Accept(HierarchicalTreeVisitor &visitor) override {
- if (visitor.PreVisit(*this)) {
- expression_->Accept(visitor);
- }
- return visitor.PostVisit(*this);
+ #>cpp
+ DEFVISITABLE(ExpressionVisitor<TypedValue>);
+ DEFVISITABLE(ExpressionVisitor<void>);
+ bool Accept(HierarchicalTreeVisitor &visitor) override {
+ if (visitor.PreVisit(*this)) {
+ expression_->Accept(visitor);
}
- cpp<#))
+ return visitor.PostVisit(*this);
+ }
+ cpp<#)
(:protected
#>cpp
using UnaryOperator::UnaryOperator;