tursom/memgraph
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

LCP: Refactor the type representation

Browse Source 
Summary:
# Summary

## Concepts and terminology

A **namestring for <object>** is a Lisp string that names the C++ language element
`<object>` (such as a namespace, a variable, a class, etc.). Therefore we have a
"namestring for a namespace", a "namestring for a variable", etc.

A **designator for a namestring for <object>** is a Lisp object that denotes a
"namestring for <object>". These are symbols and strings themselves.

A **typestring** is a Lisp string that represents a C++ type, i.e. its
declaration.

A **typestring designator** is a Lisp object that denotes a typestring.

A typestring (and the corresponding C++ type) is said to be **supported** if it
can be parsed using `parse-cpp-type-declaration`. This concept is important and
should form the base of our design because we can't really hope to ever support
all of C++'s type declarations.

A typestring (and the corresponding C++ type) that is not supported is
**unsupported**.

A **processed typestring** is a typestring that is either fully qualified or
unqualified.

A C++ type is said to be **known** if LCP knows extra information about the type,
rather than just what kind of type it is, in which namespace it lives, etc. For
now, the only known types are those that are defined within LCP itself using
`define-class` & co.

A C++ type is **unknown** if it is not known.

**Typestring resolution** is the process of resolving a (processed) typestring
into an instance of `cpp-type` or `unsupported-cpp-type`.

**Resolving accessors** are accessors which perform typestring resolution.

## Changes

Explicitly introduce the concept of supported and known types. `cpp-type` models
supported types while `unsupported-cpp-type` models unsupported types.
Subclasses of `cpp-type` model known types. `general-cpp-type` is either a
`cpp-type` or an `unsupported-cpp-type`.

Add various type queries.

Fix `define-rpc`'s `:initarg` (remove it from the `cpp-member` struct).

Introduce namestrings and their designators in `names.lisp`.

Introduce typestrings and their designators.

Introduce **processed typestrings**. Our DSL's macros (`define-class` & co.)
convert all of the given typestrings into processed typestrings because we don't
attempt to support partially qualified names and relative name lookup yet. A
warning is signalled when a partially qualified name is treated as a fully
qualified name.

The slots of `cpp-type`, `cpp-class`, `cpp-member` and `cpp-capnp-opts` now
store processed typestrings which are lazily resolved into their corresponding
C++ types.

The only thing that instances of `unsupported-cpp-type` are good for is getting
the typestring that was used to construct them. Most of LCP's functions only
work with known C++ types, i.e. `cpp-type` instances. The only function so far
that works for both of them is `cpp-type-decl`.

Since "unsupportedness" is now explicitly part of LCP, client code is expected
to manually check whether a returned type is unsupported or not (or face
receiving an error otherwise), unless a function is documented to return only
`cpp-type` instances.

A similar thing goes for "knowness". Client code is expected to manually check
whether a returned type is known or not, unless a function is documented to
return only (instances of `cpp-type` subclasses) known types.

## TODO

Resolution still has to be done for the following slots of the
following structures:

-   `slk-opts`
    -   `save-args`
    -   `load-args`

-   `clone-opts`
    -   `args`
    -   `return-type`

Reviewers: teon.banek, mtomic

Reviewed By: teon.banek

Subscribers: pullbot

Differential Revision: https://phabricator.memgraph.io/D1962
This commit is contained in:
Lovro Lugovic 2019-05-10 13:55:21 +02:00
parent e8c82e36e2
commit 017dec8c0e
11 changed files with 1899 additions and 935 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/lisp/CMakeLists.txt
View File

@ -5,6 +5,7 @@ set(lcp_src_files
${CMAKE_SOURCE_DIR}/src/lisp/lcp.asd ${CMAKE_SOURCE_DIR}/src/lisp/lcp.asd
${CMAKE_SOURCE_DIR}/src/lisp/lcp-compile ${CMAKE_SOURCE_DIR}/src/lisp/lcp-compile
${CMAKE_SOURCE_DIR}/src/lisp/package.lisp ${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/types.lisp
${CMAKE_SOURCE_DIR}/src/lisp/clone.lisp ${CMAKE_SOURCE_DIR}/src/lisp/clone.lisp
${CMAKE_SOURCE_DIR}/src/lisp/code-gen.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.asd
${CMAKE_SOURCE_DIR}/src/lisp/lcp-compile ${CMAKE_SOURCE_DIR}/src/lisp/lcp-compile
${CMAKE_SOURCE_DIR}/src/lisp/package.lisp ${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/types.lisp
${CMAKE_SOURCE_DIR}/src/lisp/clone.lisp ${CMAKE_SOURCE_DIR}/src/lisp/clone.lisp
${CMAKE_SOURCE_DIR}/src/lisp/code-gen.lisp ${CMAKE_SOURCE_DIR}/src/lisp/code-gen.lisp

227
src/lisp/clone.lisp
View File

@ -1,24 +1,5 @@
(in-package #:lcp.clone) (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) (define-condition clone-error (error)
((message :type string :initarg :message :reader clone-error-message) ((message :type string :initarg :message :reader clone-error-message)
(format-args :type list :initform nil :initarg :format-args :reader clone-error-format-args)) (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)) (error 'clone-error :message message :format-args format-args))
(defun cloning-parent (cpp-class) (defun cloning-parent (cpp-class)
(check-type cpp-class lcp::cpp-type)
(let ((supers (lcp::cpp-class-super-classes cpp-class)) (let ((supers (lcp::cpp-class-super-classes cpp-class))
(opts (lcp::cpp-class-clone-opts cpp-class))) (opts (lcp::cpp-class-clone-opts cpp-class)))
(unless opts (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 (cond
((lcp::clone-opts-base opts) nil) ((lcp::clone-opts-base opts)
((lcp::clone-opts-ignore-other-base-classes opts) (car supers)) nil)
((lcp::clone-opts-ignore-other-base-classes opts)
(car supers))
(t (t
(when (> (length supers) 1) (when (> (length supers) 1)
(clone-error "Cloning doesn't support multiple inheritance (class '~A', parents: '~A')" (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))))) (car supers)))))
(defun cloning-root (cpp-class) (defun cloning-root (cpp-class)
(check-type cpp-class lcp::cpp-type)
(let ((parent-class (cloning-parent cpp-class))) (let ((parent-class (cloning-parent cpp-class)))
(if parent-class (if parent-class
(cloning-root (lcp::find-cpp-class parent-class)) (cloning-root parent-class)
cpp-class))) cpp-class)))
(defun members-for-cloning (cpp-class) (defun members-for-cloning (cpp-class)
(do ((current-class cpp-class) members) (check-type cpp-class lcp::cpp-type)
((not current-class) members) (alexandria:flatten
(setf members (append (remove-if-not #'lcp::cpp-member-clone (reverse
(lcp::cpp-class-members current-class)) (loop :for current := cpp-class :then (cloning-parent current)
members)) :while current
(setf current-class (lcp::find-cpp-class (cloning-parent current-class))))) :collect (remove-if-not #'lcp::cpp-member-clone
(lcp::cpp-class-members current))))))
(defun copy-object (source-name dest-name) (defun copy-object (source-name dest-name)
(format nil "~A = ~A;" dest-name source-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) (defun clone-by-copy-p (object-type)
(let ((object-type (get-type object-type))) (check-type object-type lcp::cpp-type)
(cond (cond
((string= "vector" (lcp::cpp-type-name object-type)) ((string= "vector" (lcp::cpp-type-name object-type))
(clone-by-copy-p (car (lcp::cpp-type-type-args object-type)))) (clone-by-copy-p (car (lcp::cpp-type-type-args object-type))))
((string= "optional" (lcp::cpp-type-name object-type)) ((string= "optional" (lcp::cpp-type-name object-type))
(clone-by-copy-p (car (lcp::cpp-type-type-args object-type)))) (clone-by-copy-p (car (lcp::cpp-type-type-args object-type))))
((string= "unordered_map" (lcp::cpp-type-name object-type)) ((string= "unordered_map" (lcp::cpp-type-name object-type))
(and (clone-by-copy-p (first (lcp::cpp-type-type-args 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))))) (clone-by-copy-p (second (lcp::cpp-type-type-args object-type)))))
((string= "pair" (lcp::cpp-type-name object-type)) ((string= "pair" (lcp::cpp-type-name object-type))
(and (clone-by-copy-p (first (lcp::cpp-type-type-args 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))))) (clone-by-copy-p (second (lcp::cpp-type-type-args object-type)))))
((lcp::cpp-type-type-args object-type) nil) ((lcp::cpp-type-type-args object-type) nil)
((or (lcp::find-cpp-enum (lcp::cpp-type-name object-type)) ((or (lcp::cpp-enum-p object-type)
(typep object-type 'lcp::cpp-primitive-type) (lcp::cpp-type-primitive-p object-type)
(string= "string" (lcp::cpp-type-name object-type)) (string= "string" (lcp::cpp-type-name object-type))
;; TODO: We might want to forbid implicit copying of unknown types once ;; 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 ;; there's a way to globally mark type as trivially copyable. Now it is
;; too annoying to add (:clone :copy) option everywhere. ;; too annoying to add (:clone :copy) option everywhere.
(not (lcp::find-cpp-class (lcp::cpp-type-name object-type)))) (not (lcp::cpp-class-p object-type)))
t) t)
(t (t
;; We know now that we're dealing with a C++ class defined in ;; We know now that we're dealing with a C++ class defined in LCP. A class
;; LCP. A class is cloneable by copy only if it doesn't have ;; is cloneable by copy only if it doesn't have `Clone` function defined,
;; `Clone` function defined, all of its members are cloneable ;; all of its members are cloneable by copy and it is not a member of a
;; by copy and it is not a member of inheritance hierarchy. ;; class hierarchy.
(let ((cpp-class (lcp::find-cpp-class (lcp::cpp-type-name object-type)))) (assert (and (lcp::cpp-type-known-p object-type)
(assert cpp-class) (lcp::cpp-type-class-p object-type)))
(and (not (lcp::cpp-class-clone-opts cpp-class)) (and (not (lcp::cpp-class-clone-opts object-type))
(not (lcp::direct-subclasses-of cpp-class)) (not (lcp::cpp-class-direct-subclasses object-type))
(not (lcp::cpp-class-super-classes cpp-class)) (not (lcp::cpp-class-super-classes object-type))
(every (lambda (member) (every (lambda (member)
(or (eq (lcp::cpp-member-clone member) :copy) (or (eq (lcp::cpp-member-clone member) :copy)
(clone-by-copy-p (lcp::cpp-member-type member)))) (clone-by-copy-p (lcp::cpp-member-type member))))
(lcp::cpp-class-members cpp-class)))))))) (lcp::cpp-class-members object-type))))))
(defun clone-object (object-type source-name dest-name &key args) (defun clone-object (object-type source-name dest-name &key args)
(let ((object-type (get-type object-type)) (check-type object-type lcp::cpp-type)
(arg-list (format nil "~{~A~^, ~}" (let ((arg-list (format nil "~{~A~^, ~}"
(mapcar (lambda (name-and-type) (mapcar (lambda (name-and-type)
(lcp::cpp-variable-name (first name-and-type))) (lcp::cpp-name-for-variable (first name-and-type)))
args)))) args))))
(cond (cond
((clone-by-copy-p object-type) ((clone-by-copy-p object-type)
(copy-object source-name dest-name)) (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;" (format nil "~A = ~A ? ~A->Clone(~A) : nullptr;"
dest-name source-name source-name arg-list)) dest-name source-name source-name arg-list))
((string= "optional" (lcp::cpp-type-name object-type)) ((string= "optional" (lcp::cpp-type-name object-type))
@ -128,19 +105,19 @@ Usage example:
((string= "unordered_map" (lcp::cpp-type-name object-type)) ((string= "unordered_map" (lcp::cpp-type-name object-type))
(let ((key-type (first (lcp::cpp-type-type-args object-type))) (let ((key-type (first (lcp::cpp-type-type-args object-type)))
(value-type (second (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)) ((string= "pair" (lcp::cpp-type-name object-type))
(let ((first-type (first (lcp::cpp-type-type-args object-type))) (let ((first-type (first (lcp::cpp-type-type-args object-type)))
(second-type (second (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))) (clone-pair first-type second-type source-name dest-name :args args)))
((and (lcp::find-cpp-class (lcp::cpp-type-name object-type)) ((and (lcp::cpp-class-p object-type)
(lcp::cpp-class-clone-opts (lcp::find-cpp-class (lcp::cpp-type-name object-type)))) (lcp::cpp-class-clone-opts object-type))
(format nil "~A = ~A.Clone(~A);" dest-name source-name arg-list)) (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" (t (clone-error "Don't know how to clone object of type ~A"
(lcp::cpp-type-decl object-type)))))) (lcp::cpp-type-decl object-type))))))
(defun clone-vector (elem-type source-name dest-name &key args) (defun clone-vector (elem-type source-name dest-name &key args)
(with-vars ((loop-counter "i")) (lcp::with-vars ((loop-counter "i"))
(format nil (format nil
"~A.resize(~A.size()); "~A.resize(~A.size());
for (auto ~A = 0; ~A < ~A.size(); ++~A) { ~A }" for (auto ~A = 0; ~A < ~A.size(); ++~A) { ~A }"
@ -152,10 +129,11 @@ Usage example:
:args args)))) :args args))))
(defun clone-map (key-type value-type source-name dest-name &key args) (defun clone-map (key-type value-type source-name dest-name &key args)
(with-vars ((loop-var "kv") (entry-var "entry")) (lcp::with-vars ((loop-var "kv") (entry-var "entry"))
(let ((entry-type (lcp::make-cpp-type "pair" (let ((entry-type (lcp::make-cpp-type
:namespace '("std") "pair"
:type-args (list key-type value-type)))) :namespace '("std")
:type-args (list key-type value-type))))
(format nil (format nil
"for (const auto &~A : ~A) { "for (const auto &~A : ~A) {
~A ~A; ~A ~A;
@ -168,7 +146,7 @@ Usage example:
dest-name entry-var)))) dest-name entry-var))))
(defun clone-optional (value-type source-name dest-name &key args) (defun clone-optional (value-type source-name dest-name &key args)
(with-vars ((value-var "value")) (lcp::with-vars ((value-var "value"))
(format nil (format nil
"if (~A) { "if (~A) {
~A ~A; ~A ~A;
@ -187,7 +165,7 @@ Usage example:
dest-name))) dest-name)))
(defun clone-pair (first-type second-type source-name dest-name &key args) (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) (with-output-to-string (cpp-out)
(lcp::with-cpp-block-output (cpp-out) (lcp::with-cpp-block-output (cpp-out)
(format cpp-out (format cpp-out
@ -211,34 +189,39 @@ Usage example:
(defun clone-function-definition-for-class (cpp-class) (defun clone-function-definition-for-class (cpp-class)
(check-type cpp-class lcp::cpp-class) (check-type cpp-class lcp::cpp-class)
(when (lcp::cpp-type-type-params cpp-class) (when (lcp::cpp-type-class-template-p cpp-class)
(clone-error "Don't know how to clone templated class '~A'" (clone-error "Don't know how to clone class template '~A'"
(lcp::cpp-type-base-name cpp-class))) (lcp::cpp-type-name cpp-class)))
(let* ((cloning-root (cloning-root cpp-class)) (let* ((cloning-root (cloning-root cpp-class))
(root-opts (lcp::cpp-class-clone-opts cloning-root)) (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))) (cloning-parent cpp-class)))
(return-type (cond (return-type
((lcp::clone-opts-return-type root-opts) (cond
(lcp::cpp-code ((lcp::clone-opts-return-type root-opts)
(funcall (lcp::clone-opts-return-type root-opts) (lcp::cpp-code
(lcp::cpp-type-name cpp-class)))) (funcall (lcp::clone-opts-return-type root-opts)
(inheritancep (format nil "std::unique_ptr<~A>" (lcp::cpp-type-name cpp-class))))
(lcp::cpp-type-name (cloning-root cpp-class)))) (inheritancep
(t (lcp::cpp-type-name cpp-class)))) (format nil "std::unique_ptr<~A>"
(lcp::cpp-type-name (cloning-root cpp-class))))
(t
(lcp::cpp-type-name cpp-class))))
(declaration (declaration
(lcp::cpp-method-declaration cpp-class "Clone" (lcp::cpp-method-declaration
:args (lcp::clone-opts-args root-opts) cpp-class "Clone"
:returns return-type :args (lcp::clone-opts-args root-opts)
:virtual (and inheritancep :returns return-type
(eq cpp-class cloning-root)) :virtual (and inheritancep
:inline t (eq cpp-class cloning-root))
:const t :inline t
:override (and inheritancep :const t
(not (eq cpp-class cloning-root))) :override (and inheritancep
:delete (lcp::cpp-class-abstractp cpp-class)))) (not (eq cpp-class cloning-root)))
:delete (lcp::cpp-class-abstractp cpp-class))))
(if (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) (with-output-to-string (cpp-out)
(lcp::with-cpp-block-output (cpp-out :name declaration :semicolonp nil) (lcp::with-cpp-block-output (cpp-out :name declaration :semicolonp nil)
(let (object-access) (let (object-access)
@ -249,7 +232,7 @@ Usage example:
(lcp::cpp-code (lcp::cpp-code
(funcall (lcp::clone-opts-init-object root-opts) (funcall (lcp::clone-opts-init-object root-opts)
"object" (lcp::cpp-type-name cpp-class))) "object" (lcp::cpp-type-name cpp-class)))
cpp-out)) cpp-out))
(inheritancep (inheritancep
(setf object-access "object->") (setf object-access "object->")
(format cpp-out "~&auto object = std::make_unique<~A>();" (format cpp-out "~&auto object = std::make_unique<~A>();"
@ -259,17 +242,19 @@ Usage example:
(format cpp-out "~&~A object;" (format cpp-out "~&~A object;"
(lcp::cpp-type-name cpp-class)))) (lcp::cpp-type-name cpp-class))))
(dolist (member (members-for-cloning 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))) (dest (format nil "~A~A" object-access source)))
(cond (cond
((eq (lcp::cpp-member-clone member) :copy) ((eq (lcp::cpp-member-clone member) :copy)
(format cpp-out "~&~A" (copy-object source dest))) (format cpp-out "~&~A" (copy-object source dest)))
((functionp (lcp::cpp-member-clone member)) ((functionp (lcp::cpp-member-clone member))
(format cpp-out "~&~A" (format cpp-out "~&~A"
(lcp::cpp-code (funcall (lcp::cpp-member-clone member) source dest)))) (lcp::cpp-code (funcall (lcp::cpp-member-clone member)
(t source dest))))
(format cpp-out "~&~A" (t
(clone-object (lcp::cpp-member-type member) (format cpp-out "~&~A"
source dest (clone-object
:args (lcp::clone-opts-args root-opts))))))) (lcp::cpp-member-type member)
(format cpp-out "~&return object;")))))) source dest
:args (lcp::clone-opts-args root-opts)))))))
(format cpp-out "~&return object;"))))))

59
src/lisp/code-gen.lisp
View File

@ -22,8 +22,8 @@ see `CALL-WITH-CPP-BLOCK-OUTPUT' documentation."
"Invoke FUN with a function for opening C++ namespaces. The function takes "Invoke FUN with a function for opening C++ namespaces. The function takes
care to write namespaces to OUT without redundantly opening already open care to write namespaces to OUT without redundantly opening already open
namespaces." namespaces."
(declare (type stream out)) (check-type out stream)
(declare (type (function (function)) fun)) (check-type fun function)
(let (open-namespaces) (let (open-namespaces)
(funcall fun (lambda (namespaces) (funcall fun (lambda (namespaces)
;; No namespaces is global namespace ;; No namespaces is global namespace
@ -32,15 +32,15 @@ namespaces."
(declare (ignore to-close)) (declare (ignore to-close))
(format out "~%}"))) (format out "~%}")))
;; Check if we need to open or close namespaces ;; Check if we need to open or close namespaces
(loop for namespace in namespaces (loop :for namespace :in namespaces
with unmatched = open-namespaces do :with unmatched := open-namespaces :do
(if (string= namespace (car unmatched)) (if (string= namespace (car unmatched))
(setf unmatched (cdr unmatched)) (setf unmatched (cdr unmatched))
(progn (progn
(dolist (to-close unmatched) (dolist (to-close unmatched)
(declare (ignore to-close)) (declare (ignore to-close))
(format out "~%}")) (format out "~%}"))
(format out "namespace ~A {~2%" namespace)))) (format out "namespace ~A {~2%" namespace))))
(setf open-namespaces namespaces))) (setf open-namespaces namespaces)))
;; Close remaining namespaces ;; Close remaining namespaces
(dolist (to-close open-namespaces) (dolist (to-close open-namespaces)
@ -60,25 +60,30 @@ context which binds OPEN-NAMESPACE-FUN function for opening namespaces."
(defun cpp-documentation (documentation) (defun cpp-documentation (documentation)
"Convert DOCUMENTATION to Doxygen style string." "Convert DOCUMENTATION to Doxygen style string."
(declare (type string documentation)) (check-type documentation string)
(format nil "/// ~A" (format nil "/// ~A"
(cl-ppcre:regex-replace-all (cl-ppcre:regex-replace-all
(string #\Newline) documentation (format nil "~%/// ")))) (string #\Newline) documentation (format nil "~%/// "))))
(defun cpp-variable-name (symbol) (defvar *variable-idx* 0 "Used to generate unique variable names")
"Get C++ style name of SYMBOL as a string."
(declare (type (or string symbol) symbol))
(cl-ppcre:regex-replace-all "-" (string-downcase symbol) "_"))
(defun cpp-enumerator-name (symbol) (defmacro with-vars (vars &body body)
"Get C++ style enumerator name of SYMBOL as a string. This is like "Generates unique variable names for use in generated code by
`CPP-VARIABLE-NAME' but upcased." appending an index to desired variable names. Useful when generating
(declare (type (or string symbol) symbol)) loops which might reuse counter names.
(cl-ppcre:regex-replace-all "-" (string-upcase symbol) "_"))
(defun cpp-member-name (cpp-member &key struct) Usage example:
"Get C++ style name of the `CPP-MEMBER' as a string." (with-vars ((loop-counter \"i\"))
(declare (type cpp-member cpp-member) (format nil \"for (auto ~A = 0; ~A < v.size(); ++~A) {
(type boolean struct)) // do something
(let ((cpp-name (cpp-variable-name (cpp-member-symbol cpp-member)))) }\"
(if struct cpp-name (format nil "~A_" cpp-name)))) 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)))

4
src/lisp/lcp.asd
View File

@ -2,10 +2,12 @@
:description "LCP: The Lisp C++ Preprocessor" :description "LCP: The Lisp C++ Preprocessor"
:version "0.0.1" :version "0.0.1"
:author "Teon Banek <teon.banek@memgraph.io>" :author "Teon Banek <teon.banek@memgraph.io>"
:depends-on ("cl-ppcre" "named-readtables" "swank") :depends-on ("alexandria" "cl-ppcre" "named-readtables" "swank")
:serial t :serial t
:components ((:file "package") :components ((:file "package")
(:file "util")
(:file "reader") (:file "reader")
(:file "names")
(:file "types") (:file "types")
(:file "code-gen") (:file "code-gen")
(:file "slk") (:file "slk")

323
src/lisp/lcp.lisp
View File

@ -4,69 +4,64 @@
(in-package #:lcp) (in-package #:lcp)
(named-readtables:in-readtable lcp-syntax) (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 (defvar *generating-cpp-impl-p* nil
"T if we are currently writing the .cpp file.") "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." ;;; C++ code generation
(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))
(defun cpp-enum-definition (cpp-enum) (defun cpp-enum-definition (cpp-enum)
"Get C++ style `CPP-ENUM' definition as a string." "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) (with-output-to-string (s)
(when (cpp-type-documentation cpp-enum) (when (cpp-type-documentation cpp-enum)
(write-line (cpp-documentation (cpp-type-documentation cpp-enum)) s)) (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)) (with-cpp-block-output (s :name (format nil "enum class ~A" (cpp-type-name cpp-enum))
:semicolonp t) :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." "Get C++ style `CPP-MEMBER' declaration as a string."
(declare (type cpp-member cpp-member) (check-type cpp-member cpp-member)
(type boolean struct)) (let ((type-name (cpp-type-decl (cpp-member-type cpp-member))))
(let ((type-name (cpp-type-name (cpp-member-type cpp-member))))
(with-output-to-string (s) (with-output-to-string (s)
(when (cpp-member-documentation cpp-member) (when (cpp-member-documentation cpp-member)
(write-line (cpp-documentation (cpp-member-documentation cpp-member)) s)) (write-line (cpp-documentation (cpp-member-documentation cpp-member)) s))
(if (cpp-member-initval cpp-member) (if (cpp-member-initval cpp-member)
(format s "~A ~A{~A};" type-name (format s "~A ~A{~A};"
(cpp-member-name cpp-member :struct struct) (cpp-member-initval cpp-member)) type-name
(format s "~A ~A;" type-name (cpp-member-name cpp-member :struct struct)))))) (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) (defun cpp-member-reader-definition (cpp-member)
"Get C++ style `CPP-MEMBER' getter (reader) function." "Get C++ style `CPP-MEMBER' getter (reader) function."
(declare (type cpp-member cpp-member)) (check-type cpp-member cpp-member)
(if (typep (cpp-member-type cpp-member) 'cpp-primitive-type-keywords) (if (cpp-type-primitive-p (cpp-member-type cpp-member))
(format nil "auto ~A() const { return ~A; }" (cpp-member-name cpp-member :struct t) (cpp-member-name cpp-member)) (format nil "auto ~A() const { return ~A; }"
(format nil "const auto &~A() const { return ~A; }" (cpp-member-name cpp-member :struct t) (cpp-member-name cpp-member)))) (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) (defun cpp-template (type-params &optional stream)
"Generate C++ template declaration from provided TYPE-PARAMS. If STREAM is "Generate C++ template declaration from provided TYPE-PARAMS. If STREAM is
NIL, returns a string." NIL, returns a string."
(format stream "template <~{class ~A~^,~^ ~}>" (format stream "template <~{class ~A~^,~^ ~}>" type-params))
(mapcar #'cpp-type-name type-params)))
(defun type-info-declaration-for-class (cpp-class) (defun type-info-declaration-for-class (cpp-class)
(assert (and (not (cpp-type-type-params cpp-class)) (assert (cpp-type-simple-class-p cpp-class))
(not (cpp-type-type-args cpp-class))))
(with-output-to-string (s) (with-output-to-string (s)
(write-line "static const utils::TypeInfo kType;" s) (write-line "static const utils::TypeInfo kType;" s)
(let* ((type-info-basep (type-info-opts-base (cpp-class-type-info-opts cpp-class))) (let* ((type-info-basep (type-info-opts-base
(virtual (if (and (or type-info-basep (not (cpp-class-super-classes cpp-class))) (cpp-class-type-info-opts cpp-class)))
(direct-subclasses-of cpp-class)) (virtual (if (and (or type-info-basep
(not (cpp-class-super-classes cpp-class)))
(cpp-class-direct-subclasses cpp-class))
"virtual" "virtual"
"")) ""))
(override (if (and (not type-info-basep) (override (if (and (not type-info-basep)
@ -77,64 +72,66 @@ NIL, returns a string."
virtual override)))) virtual override))))
(defun type-info-definition-for-class (cpp-class) (defun type-info-definition-for-class (cpp-class)
(assert (and (not (cpp-type-type-params cpp-class)) (assert (cpp-type-simple-class-p cpp-class))
(not (cpp-type-type-args cpp-class))))
(with-output-to-string (s) (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)))) (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)))) (setf super-classes (list (first super-classes))))
(when (> (length super-classes) 1) (when (> (length super-classes) 1)
(error "Unable to generate TypeInfo for class '~A' due to multiple inheritance!" (error "Unable to generate TypeInfo for class '~A' due to multiple inheritance!"
(cpp-type-base-name cpp-class))) (cpp-type-name cpp-class)))
(flet ((get-super-type-info (super) (format s "const utils::TypeInfo ~A::kType{0x~XULL, \"~A\", ~A};~%"
(let ((super-class (find-cpp-class super))) (if *generating-cpp-impl-p*
(format nil "&~A::kType" (cpp-type-name cpp-class)
(if super-class ;; Use full type declaration if class definition
(cpp-type-decl super-class) ;; isn't inside the .cpp file.
(cpp-type-name super)))))) (cpp-type-decl cpp-class))
(format s "const utils::TypeInfo ~A::kType{0x~XULL, \"~A\", ~A};~%" ;; Use full type declaration for hash
(if *generating-cpp-impl-p* (fnv1a64-hash-string (cpp-type-decl cpp-class))
(cpp-type-name cpp-class) (cpp-type-name cpp-class)
;; Use full type declaration if class definition (if super-classes
;; isn't inside the .cpp file. (format nil "&~A::kType"
(cpp-type-decl cpp-class)) (cpp-type-decl (first super-classes)))
;; Use full type declaration for hash "nullptr")))))
(fnv1a64-hash-string (cpp-type-decl cpp-class))
(cpp-type-name cpp-class)
(if super-classes (get-super-type-info (first super-classes)) "nullptr"))))))
(defun cpp-class-definition (cpp-class) (defun cpp-class-definition (cpp-class)
"Get C++ definition of the CPP-CLASS as a string." "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) (flet ((cpp-class-members-scoped (scope)
(remove-if (lambda (m) (not (eq scope (cpp-member-scope m)))) (remove-if (lambda (m) (not (eq scope (cpp-member-scope m))))
(cpp-class-members cpp-class))) (cpp-class-members cpp-class)))
(member-declaration (member) (member-declaration (member)
(cpp-member-declaration member :struct (cpp-class-structp cpp-class)))) (cpp-member-declaration member)))
(with-output-to-string (s) (with-output-to-string (s)
(terpri s) (terpri s)
(when (cpp-type-documentation cpp-class) (when (cpp-type-documentation cpp-class)
(write-line (cpp-documentation (cpp-type-documentation cpp-class)) s)) (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)) (cpp-template (cpp-type-type-params cpp-class) s))
(if (cpp-class-structp cpp-class) (if (cpp-class-structp cpp-class)
(write-string "struct " s) (write-string "struct " s)
(write-string "class " s)) (write-string "class " s))
(format s "~A" (cpp-type-name cpp-class)) (format s "~A" (cpp-type-name cpp-class))
(when (cpp-class-super-classes cpp-class) (let ((super-classes (cpp-class-super-classes cpp-class)))
(format s " : ~{public ~A~^, ~}" (when super-classes
(mapcar #'cpp-type-name (cpp-class-super-classes cpp-class)))) (format s " : ~{public ~A~^, ~}"
(mapcar #'cpp-type-decl super-classes))))
(with-cpp-block-output (s :semicolonp t) (with-cpp-block-output (s :semicolonp t)
(let ((reader-members (remove-if (complement #'cpp-member-reader) (let ((reader-members (remove-if (complement #'cpp-member-reader)
(cpp-class-members cpp-class)))) (cpp-class-members cpp-class))))
(when (or (cpp-class-public cpp-class) (cpp-class-members-scoped :public) reader-members (when (or (cpp-class-public cpp-class)
;; We at least have public TypeInfo object for non-template classes. (cpp-class-members-scoped :public)
(not (cpp-type-type-params cpp-class))) 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) (unless (cpp-class-structp cpp-class)
(write-line " public:" s)) (write-line " public:" s))
(unless (cpp-type-type-params cpp-class) ;; Skip generating TypeInfo for class templates.
;; Skip generating TypeInfo for template classes. (unless (cpp-type-class-template-p cpp-class)
(write-line (type-info-declaration-for-class cpp-class) s)) (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-code (cpp-class-public cpp-class)))
(format s "~{~%~A~}~%" (mapcar #'cpp-member-reader-definition reader-members)) (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 #'cpp-code (cpp-class-private cpp-class)))
(format s "~{ ~%~A~}~%" (format s "~{ ~%~A~}~%"
(mapcar #'member-declaration (cpp-class-members-scoped :private))))) (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. ;; 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))) (let ((typeinfo-def (type-info-definition-for-class cpp-class)))
(if *generating-cpp-impl-p* (if *generating-cpp-impl-p*
(write-line typeinfo-def s) (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 "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 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" the function. TYPE-PARAMS is a list of names for template argments"
(declare (type string name)) (check-type name string)
(declare (type string returns)) (check-type returns string)
(let ((template (if type-params (cpp-template type-params) "")) (let ((template (if type-params (cpp-template type-params) ""))
(args (format nil "~:{~A ~A~:^, ~}" (args (format nil "~:{~A ~A~:^, ~}"
(mapcar (lambda (name-and-type) (mapcar (lambda (name-and-type)
(list (cpp-type-name (second name-and-type)) (list (ensure-typestring (second name-and-type))
(cpp-variable-name (first name-and-type)))) (ensure-namestring-for-variable (first name-and-type))))
args)))) args))))
(raw-cpp-string (raw-cpp-string
#>cpp #>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 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 declaration to be used outside of class definition. Remaining keys are flags
which generate the corresponding C++ keywords." which generate the corresponding C++ keywords."
(declare (type cpp-class class) (check-type class cpp-class)
(type string method-name)) (check-type method-name string)
(let* ((type-params (cpp-type-type-params class)) (let* ((type-params (cpp-type-type-params class))
(template (if (or inline (not type-params)) "" (cpp-template type-params))) (template (if (or inline (not type-params)) "" (cpp-template type-params)))
(static/virtual (cond (static/virtual (cond
((and inline static) "static") ((and inline static) "static")
((and inline virtual) "virtual") ((and inline virtual) "virtual")
(t ""))) (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~:^, ~}" (args (format nil "~:{~A ~A~:^, ~}"
(mapcar (lambda (name-and-type) (mapcar (lambda (name-and-type)
(list (cpp-type-name (second name-and-type)) (list (ensure-typestring (second name-and-type))
(cpp-variable-name (first name-and-type)))) (ensure-namestring-for-variable (first name-and-type))))
args))) args)))
(const (if const "const" "")) (const (if const "const" ""))
(override (if (and override inline) "override" "")) (override (if (and override inline) "override" ""))
@ -229,22 +228,20 @@ which generate the corresponding C++ keywords."
(null "") (null "")
(otherwise (error "Unknown conversion to C++ for ~S" (type-of cpp))))) (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 (defvar *cpp-namespaces* nil
"Stack of C++ namespaces we are generating the code in.") "Stack of C++ namespaces we are generating the code in.")
(defmacro namespace (name) (defmacro namespace (name)
"Push the NAME to currently set namespaces." "Push the NAME to currently set namespaces."
(declare (type symbol name)) (check-type name symbol)
(let ((cpp-namespace (cpp-variable-name name))) (let ((cpp-namespace (cpp-name-for-variable name)))
`(progn `(progn
(push ,cpp-namespace *cpp-namespaces*) (push ,cpp-namespace *cpp-namespaces*)
(make-raw-cpp (make-raw-cpp
@ -254,8 +251,9 @@ which generate the corresponding C++ keywords."
(pop *cpp-namespaces*) (pop *cpp-namespaces*)
#>cpp } cpp<#) #>cpp } cpp<#)
(defvar *cpp-impl* nil "List of (namespace . C++ code) pairs that should be (defvar *cpp-impl* nil
written in the implementation (.cpp) file.") "List of (namespace . C++ code) pairs that should be written in the
implementation (.cpp) file.")
(defun in-impl (&rest args) (defun in-impl (&rest args)
(let ((namespaces (reverse *cpp-namespaces*))) (let ((namespaces (reverse *cpp-namespaces*)))
@ -263,139 +261,34 @@ which generate the corresponding C++ keywords."
(append *cpp-impl* (mapcar (lambda (cpp) (cons namespaces cpp)) (append *cpp-impl* (mapcar (lambda (cpp) (cons namespaces cpp))
args))))) 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) (defun read-lcp (filepath)
"Read the FILEPATH and return a list of C++ meta information that should be "Read the file FILEPATH and return a list of C++ meta information that should
formatted and output." be formatted and output."
(with-open-file (in-stream filepath) (with-open-file (in-stream filepath)
(let ((*readtable* (named-readtables:find-readtable 'lcp-syntax)) (let ((*readtable* (named-readtables:find-readtable 'lcp-syntax))
(stream-pos 0)) (stream-pos 0))
(handler-case (handler-case
(loop for form = (read-preserving-whitespace in-stream nil 'eof) (loop :for form := (read-preserving-whitespace in-stream nil 'eof)
until (eq form 'eof) :until (eq form 'eof)
for res = (handler-case (eval form) :for res := (handler-case (eval form)
(error (err) (error (err)
(file-position in-stream 0) ;; start of stream ;; Seek to the start of the stream.
(error "~%~A:~A: error:~2%~A~2%in:~2%~A" (file-position in-stream 0)
(uiop:native-namestring filepath) (error "~%~A:~A: error:~2%~A~2%in:~2%~A"
(count-newlines in-stream :stop-position (1+ stream-pos)) (uiop:native-namestring filepath)
err form))) (count-newlines
do (setf stream-pos (file-position in-stream)) in-stream
when (typep res '(or raw-cpp cpp-type cpp-list)) :stop-position (1+ stream-pos))
collect res) 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 () (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 ')'?" (error "~%~A:~A:error: READ error, did you forget a closing ')'?"
(uiop:native-namestring filepath) (uiop:native-namestring filepath)
(count-newlines in-stream (count-newlines in-stream :stop-position (1+ stream-pos))))))))
:stop-position (1+ stream-pos))))))))
(defun process-file (lcp-file &key slk-serialize) (defun process-file (lcp-file &key slk-serialize)
"Process a LCP-FILE and write the output to .hpp file in the same directory." "Process a LCP-FILE and write the output to .hpp file in the same directory."
@ -443,7 +336,7 @@ formatted and output."
(cpp-class (cpp-class
(format out "~A;~%" (lcp.slk:save-function-declaration-for-class type-for-slk)) (format out "~A;~%" (lcp.slk:save-function-declaration-for-class type-for-slk))
(when (or (cpp-class-super-classes 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))) (format out "~A;~%" (lcp.slk:construct-and-load-function-declaration-for-class type-for-slk)))
(unless (cpp-class-abstractp type-for-slk) (unless (cpp-class-abstractp type-for-slk)
(format out "~A;~%" (lcp.slk:load-function-declaration-for-class 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 ;; Top level functions
(write-line (lcp.slk:save-function-definition-for-class cpp-type) out) (write-line (lcp.slk:save-function-definition-for-class cpp-type) out)
(when (or (cpp-class-super-classes cpp-type) (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))) (format out "~A;~%" (lcp.slk:construct-and-load-function-definition-for-class cpp-type)))
(unless (cpp-class-abstractp cpp-type) (unless (cpp-class-abstractp cpp-type)
(write-line (lcp.slk:load-function-definition-for-class cpp-type) out))) (write-line (lcp.slk:load-function-definition-for-class cpp-type) out)))

193
src/lisp/names.lisp Normal file
View File

@ -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))

292
src/lisp/slk.lisp
View File

@ -1,6 +1,6 @@
;;;; This file contains code generation for serialization to our Save Load ;;;; This file contains code generation for serialization to our Save Load Kit
;;;; Kit (SLK). It works very similarly to Cap'n Proto serialization, but ;;;; (SLK). It works very similarly to Cap'n Proto serialization, but without
;;;; without the schema generation. ;;;; the schema generation.
(in-package #:lcp.slk) (in-package #:lcp.slk)
@ -26,94 +26,94 @@
supers)))) supers))))
(defun save-extra-args (cpp-class) (defun save-extra-args (cpp-class)
"Get additional arguments to Save function for CPP-CLASS. Note, returned "Get additional arguments to Save function for CPP-CLASS. Note, returned extra
extra arguments are of the first class encountered when traversing the arguments are of the first class encountered when traversing the hierarchy from
hierarchy from CPP-CLASS to parents." CPP-CLASS to parents."
(let ((opts (lcp::cpp-class-slk-opts cpp-class))) (let ((opts (lcp::cpp-class-slk-opts cpp-class)))
(if (and opts (lcp::slk-opts-save-args opts)) (if (and opts (lcp::slk-opts-save-args opts))
(lcp::slk-opts-save-args opts) (lcp::slk-opts-save-args opts)
(let ((parents (cpp-class-super-classes-for-slk cpp-class))) (let ((parents (cpp-class-super-classes-for-slk cpp-class)))
(dolist (parent parents) (dolist (parent parents)
(let ((parent-class (lcp::find-cpp-class parent))) (when (lcp::cpp-type-known-p parent)
(when parent-class (return (save-extra-args parent))))))))
(return (save-extra-args parent-class)))))))))
(defun load-extra-args (cpp-class) (defun load-extra-args (cpp-class)
"Get additional arguments to Load function for CPP-CLASS. Note, returned "Get additional arguments to Load function for CPP-CLASS. Note, returned extra
extra arguments are of the first class encountered when traversing the arguments are of the first class encountered when traversing the hierarchy from
hierarchy from CPP-CLASS to parents." CPP-CLASS to parents."
(let ((opts (lcp::cpp-class-slk-opts cpp-class))) (let ((opts (lcp::cpp-class-slk-opts cpp-class)))
(if (and opts (lcp::slk-opts-load-args opts)) (if (and opts (lcp::slk-opts-load-args opts))
(lcp::slk-opts-load-args opts) (lcp::slk-opts-load-args opts)
(let ((parents (cpp-class-super-classes-for-slk cpp-class))) (let ((parents (cpp-class-super-classes-for-slk cpp-class)))
(dolist (parent parents) (dolist (parent parents)
(let ((parent-class (lcp::find-cpp-class parent))) (when (lcp::cpp-type-known-p parent)
(when parent-class (return (load-extra-args parent))))))))
(return (load-extra-args parent-class)))))))))
(defun save-function-declaration-for-class (cpp-class) (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." generation expects the declarations and definitions to be in `slk` namespace."
(check-type cpp-class lcp::cpp-class) (check-type cpp-class lcp::cpp-class)
(when (lcp::cpp-type-type-params cpp-class) (when (lcp::cpp-type-class-template-p cpp-class)
(slk-error "Don't know how to save templated class '~A'" (slk-error "Don't know how to save class template '~A'"
(lcp::cpp-type-base-name cpp-class))) (lcp::cpp-type-name cpp-class)))
(when (< 1 (list-length (cpp-class-super-classes-for-slk 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'" (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 (let ((self-arg
(list 'self (format nil "const ~A &" (list 'self (format nil "const ~A &"
(lcp::cpp-type-decl cpp-class)))) (lcp::cpp-type-decl cpp-class))))
(builder-arg (list 'builder "slk::Builder *"))) (builder-arg (list 'builder "slk::Builder *")))
(lcp::cpp-function-declaration (lcp::cpp-function-declaration
"Save" :args (cons self-arg (cons builder-arg (save-extra-args cpp-class))) "Save" :args (list* self-arg builder-arg (save-extra-args cpp-class))
:type-params (lcp::cpp-type-type-params cpp-class)))) :type-params (lcp::cpp-type-type-params cpp-class))))
(defun construct-and-load-function-declaration-for-class (cpp-class) (defun construct-and-load-function-declaration-for-class (cpp-class)
"Generate SLK construct and load function declaration for CPP-CLASS. This "Generate SLK construct and load function declaration for CPP-CLASS. This
function needs to be used to load pointers to polymorphic types. Note that function needs to be used to load pointers to polymorphic types. Note that the
the code generation expects the declarations and definitions to be in `slk` code generation expects the declarations and definitions to be in `slk`
namespace." namespace."
(check-type cpp-class lcp::cpp-class) (check-type cpp-class lcp::cpp-class)
(when (lcp::cpp-type-type-params cpp-class) (when (lcp::cpp-type-class-template-p cpp-class)
(slk-error "Don't know how to load templated class '~A'" (slk-error "Don't know how to load class template '~A'"
(lcp::cpp-type-base-name cpp-class))) (lcp::cpp-type-name cpp-class)))
(when (< 1 (list-length (cpp-class-super-classes-for-slk 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'" (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 (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 *"))) (reader-arg (list 'reader "slk::Reader *")))
(lcp::cpp-function-declaration (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)))) :type-params (lcp::cpp-type-type-params cpp-class))))
(defun load-function-declaration-for-class (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." generation expects the declarations and definitions to be in `slk` namespace."
(check-type cpp-class lcp::cpp-class) (check-type cpp-class lcp::cpp-class)
(when (lcp::cpp-type-type-params cpp-class) (when (lcp::cpp-type-class-template-p cpp-class)
(slk-error "Don't know how to load templated class '~A'" (slk-error "Don't know how to load class template '~A'"
(lcp::cpp-type-base-name cpp-class))) (lcp::cpp-type-name cpp-class)))
(when (< 1 (list-length (cpp-class-super-classes-for-slk 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'" (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 (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 *"))) (reader-arg (list 'reader "slk::Reader *")))
(lcp::cpp-function-declaration (lcp::cpp-function-declaration
"Load" :args (cons self-arg (cons reader-arg (load-extra-args cpp-class))) "Load" :args (list* self-arg reader-arg (load-extra-args cpp-class))
:type-params (lcp::cpp-type-type-params cpp-class)))) :type-params (lcp::cpp-type-type-params cpp-class))))
(defun save-members (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." serializable member has no public access."
(with-output-to-string (s) (with-output-to-string (s)
(dolist (member (lcp::cpp-class-members-for-save cpp-class)) (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))) (when (not (eq :public (lcp::cpp-member-scope member)))
(slk-error "Cannot save non-public member '~A' of '~A'" (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 (cond
((lcp::cpp-member-slk-save member) ((lcp::cpp-member-slk-save member)
;; Custom save function ;; Custom save function
@ -122,10 +122,10 @@ serializable member has no public access."
member-name)) member-name))
s))) s)))
;; TODO: Maybe support saving (but not loading) unique_ptr. ;; 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'" (slk-error "Don't know how to save pointer '~A' in '~A'"
(lcp::cpp-member-type member) (lcp::cpp-type-decl (lcp::cpp-member-type member))
(lcp::cpp-type-base-name cpp-class))) (lcp::cpp-type-name cpp-class)))
;; TODO: Extra args for cpp-class members ;; TODO: Extra args for cpp-class members
(t (t
(format s "slk::Save(self.~A, builder);~%" member-name))))))) (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))) (lcp::cpp-class-members cpp-class)))
(defun load-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." serializable member has no public access."
(with-output-to-string (s) (with-output-to-string (s)
(dolist (member (members-for-load cpp-class)) (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))) (when (not (eq :public (lcp::cpp-member-scope member)))
(slk-error "Cannot save non-public member '~A' of '~A'" (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 (cond
((lcp::cpp-member-slk-load member) ((lcp::cpp-member-slk-load member)
;; Custom load function ;; 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) (write-line (lcp::cpp-code (funcall (lcp::cpp-member-slk-load member)
member-name)) member-name))
s))) 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'" (slk-error "Don't know how to load pointer '~A' in '~A'"
(lcp::cpp-member-type member) (lcp::cpp-type-decl (lcp::cpp-member-type member))
(lcp::cpp-type-base-name cpp-class))) (lcp::cpp-type-name cpp-class)))
;; TODO: Extra args for cpp-class members ;; TODO: Extra args for cpp-class members
(t (t
(format s "slk::Load(&self->~A, reader);~%" member-name))))))) (format s "slk::Load(&self->~A, reader);~%" member-name)))))))
(defun save-parents-recursively (cpp-class) (defun save-parents-recursively (cpp-class)
"Generate code for saving members of all parents, recursively. Raise "Generate code for saving members of all parents, recursively. Raise
`SLK-ERROR' if trying to save templated parent class or if using multiple `SLK-ERROR' if CPP-CLASS has multiple superclasses or if any ancestor is a class
inheritance." template."
(when (< 1 (list-length (cpp-class-super-classes-for-slk 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'" (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) (with-output-to-string (s)
(dolist (parent (cpp-class-super-classes-for-slk cpp-class)) (dolist (parent (cpp-class-super-classes-for-slk cpp-class))
(let ((parent-class (lcp::find-cpp-class parent))) (cond
(cond ((not (lcp::cpp-type-known-p parent))
((not parent-class) (slk-error
(slk-error "Class '~A' has an unknown parent '~A', serialization is incomplete. Did you forget to mark '~A' as base?"
"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-base-name cpp-class) parent (lcp::cpp-type-base-name cpp-class))) (lcp::cpp-type-name parent)
((lcp::cpp-type-type-params parent-class) (lcp::cpp-type-name cpp-class)))
(slk-error "Don't know how to save templated parent class '~A'" ((lcp::cpp-type-class-template-p parent)
(lcp::cpp-type-base-name parent-class))) (slk-error "Don't know how to save parent class template '~A'"
(t (lcp::cpp-type-name parent)))
(format s "// Save parent ~A~%" (lcp::cpp-type-name parent)) (t
(lcp::with-cpp-block-output (s) (format s "// Save parent ~A~%" (lcp::cpp-type-name parent))
(write-string (save-parents-recursively parent-class) s) (lcp::with-cpp-block-output (s)
(write-string (save-members parent-class) s)))))))) (write-string (save-parents-recursively parent) s)
(write-string (save-members parent) s)))))))
(defun load-parents-recursively (cpp-class) (defun load-parents-recursively (cpp-class)
"Generate code for loading members of all parents, recursively. Raise "Generate code for loading members of all parents, recursively. Raise
`SLK-ERROR' if trying to load templated parent class or if using multiple `SLK-ERROR' if CPP-CLASS has multiple superclasses or if any ancestor is a class
inheritance." template."
(when (< 1 (list-length (cpp-class-super-classes-for-slk 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'" (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) (with-output-to-string (s)
(dolist (parent (cpp-class-super-classes-for-slk cpp-class)) (dolist (parent (cpp-class-super-classes-for-slk cpp-class))
(let ((parent-class (lcp::find-cpp-class parent))) (cond
(cond ((not (lcp::cpp-type-known-p parent))
((not parent-class) (slk-error
(slk-error "Class '~A' has an unknown parent '~A', serialization is incomplete. Did you forget to mark '~A' as base?"
"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-base-name cpp-class) parent (lcp::cpp-type-base-name cpp-class))) (lcp::cpp-type-name parent)
((lcp::cpp-type-type-params parent-class) (lcp::cpp-type-name cpp-class)))
(slk-error "Don't know how to load templated parent class '~A'" ((lcp::cpp-type-type-params parent)
(lcp::cpp-type-base-name parent-class))) (slk-error "Don't know how to load parent class template '~A'"
(t (lcp::cpp-type-name parent)))
(format s "// Load parent ~A~%" (lcp::cpp-type-name parent)) (t
(lcp::with-cpp-block-output (s) (format s "// Load parent ~A~%" (lcp::cpp-type-name parent))
(write-string (load-parents-recursively parent-class) s) (lcp::with-cpp-block-output (s)
(write-string (load-members parent-class) s)))))))) (write-string (load-parents-recursively parent) s)
(write-string (load-members parent) s)))))))
(defun forward-save-to-subclasses (cpp-class) (defun forward-save-to-subclasses (cpp-class)
"Generate code which forwards the serialization to derived classes of "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) (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) (dolist (subclass subclasses)
(when (lcp::cpp-type-type-params subclass) (when (lcp::cpp-type-class-template-p subclass)
(slk-error "Don't know how to save derived templated class '~A'" (slk-error "Don't know how to save derived class template '~A'"
(lcp::cpp-type-base-name subclass))) (lcp::cpp-type-name subclass)))
(let ((derived-class (lcp::cpp-type-decl 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) (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)))) (save-extra-args cpp-class))))
(format s "if (const auto *~A_derived = utils::Downcast<const ~A>(&self)) { (format s "if (const auto *~A_derived = utils::Downcast<const ~A>(&self)) {
return slk::Save(*~A_derived, builder~{, ~A~}); }~%" return slk::Save(*~A_derived, builder~{, ~A~}); }~%"
derived-var derived-class derived-var extra-args)))))) derived-var derived-class derived-var extra-args))))))
(defun save-function-code-for-class (cpp-class) (defun save-function-code-for-class (cpp-class)
"Generate code for serializing CPP-CLASS. Raise `SLK-ERROR' on unsupported "Generate code for serializing CPP-CLASS. Raise `SLK-ERROR' on unsupported C++
C++ constructs, mostly related to templates." constructs, mostly related to templates."
(when (lcp::cpp-type-type-params cpp-class) (when (lcp::cpp-type-class-template-p cpp-class)
(slk-error "Don't know how to save templated class '~A'" (slk-error "Don't know how to save class template '~A'"
(lcp::cpp-type-base-name cpp-class))) (lcp::cpp-type-name cpp-class)))
(with-output-to-string (s) (with-output-to-string (s)
(cond (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. ;; We have more derived classes, so forward the call to them.
(write-string (forward-save-to-subclasses cpp-class) s) (write-string (forward-save-to-subclasses cpp-class) s)
(if (lcp::cpp-class-abstractp cpp-class) (if (lcp::cpp-class-abstractp cpp-class)
@ -255,16 +257,16 @@ C++ constructs, mostly related to templates."
(write-string (save-members cpp-class) s))))) (write-string (save-members cpp-class) s)))))
(defun construct-and-load-function-code-for-class (cpp-class) (defun construct-and-load-function-code-for-class (cpp-class)
"Generate code for serializing CPP-CLASS. Raise `SLK-ERROR' on unsupported "Generate code for serializing CPP-CLASS. Raise `SLK-ERROR' on unsupported C++
C++ constructs, mostly related to templates." constructs, mostly related to templates."
(assert (or (cpp-class-super-classes-for-slk cpp-class) (assert (or (cpp-class-super-classes-for-slk cpp-class)
(lcp::direct-subclasses-of cpp-class))) (lcp::cpp-class-direct-subclasses cpp-class)))
(when (lcp::cpp-type-type-params cpp-class) (when (lcp::cpp-type-class-template-p cpp-class)
(slk-error "Don't know how to load templated class '~A'" (slk-error "Don't know how to load class template '~A'"
(lcp::cpp-type-base-name cpp-class))) (lcp::cpp-type-name cpp-class)))
(labels ((concrete-subclasses-rec (class) (labels ((concrete-subclasses-rec (class)
(let ((concrete-classes nil)) (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) (unless (lcp::cpp-class-abstractp subclass)
(push subclass concrete-classes)) (push subclass concrete-classes))
(setf concrete-classes (setf concrete-classes
@ -277,9 +279,9 @@ C++ constructs, mostly related to templates."
(push cpp-class concrete-classes)) (push cpp-class concrete-classes))
(dolist (concrete-class concrete-classes) (dolist (concrete-class concrete-classes)
(let ((type-decl (lcp::cpp-type-decl concrete-class)) (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) (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)))) (load-extra-args cpp-class))))
(lcp::with-cpp-block-output (lcp::with-cpp-block-output
(s :name (format nil "if (~A::kType.id == type_id)" type-decl)) (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))))) (write-line "throw slk::SlkDecodeException(\"Trying to load unknown derived type!\");" s)))))
(defun load-function-code-for-class (cpp-class) (defun load-function-code-for-class (cpp-class)
"Generate code for serializing CPP-CLASS. Raise `SLK-ERROR' on unsupported "Generate code for serializing CPP-CLASS. Raise `SLK-ERROR' on unsupported C++
C++ constructs, mostly related to templates." constructs, mostly related to templates."
(when (lcp::cpp-type-type-params cpp-class) (when (lcp::cpp-type-class-template-p cpp-class)
(slk-error "Don't know how to load templated class '~A'" (slk-error "Don't know how to load class template '~A'"
(lcp::cpp-type-base-name cpp-class))) (lcp::cpp-type-name cpp-class)))
(assert (not (lcp::cpp-class-abstractp cpp-class))) (assert (not (lcp::cpp-class-abstractp cpp-class)))
(with-output-to-string (s) (with-output-to-string (s)
;; We are assuming that the generated code is called only in cases when we ;; 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 ;; really have this particular class instantiated and not any of the
;; derived ones. ;; 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)) (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-line "throw slk::SlkDecodeException(\"Trying to load incorrect derived type!\");" s))
(write-string (load-parents-recursively cpp-class) s) (write-string (load-parents-recursively cpp-class) s)
(write-string (load-members cpp-class) s))) (write-string (load-members cpp-class) s)))
(defun save-function-definition-for-class (cpp-class) (defun save-function-definition-for-class (cpp-class)
"Generate SLK save function. Raise `SLK-ERROR' if an unsupported or invalid "Generate SLK save function. Raise `SLK-ERROR' if an unsupported or invalid
class definition is encountered during code generation. Note that the code class definition is encountered during code generation. Note that the code
generation expects the declarations and definitions to be in `slk` namespace." generation expects the declarations and definitions to be in `slk` namespace."
(check-type cpp-class lcp::cpp-class) (check-type cpp-class lcp::cpp-class)
(with-output-to-string (cpp-out) (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)))) (write-line (save-function-code-for-class cpp-class) cpp-out))))
(defun load-function-definition-for-class (cpp-class) (defun load-function-definition-for-class (cpp-class)
"Generate SLK load function. Raise `SLK-ERROR' if an unsupported or invalid "Generate SLK load function. Raise `SLK-ERROR' if an unsupported or invalid
class definition is encountered during code generation. Note that the code class definition is encountered during code generation. Note that the code
generation expects the declarations and definitions to be in `slk` namespace." generation expects the declarations and definitions to be in `slk` namespace."
(check-type cpp-class lcp::cpp-class) (check-type cpp-class lcp::cpp-class)
(with-output-to-string (cpp-out) (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)))) (write-line (load-function-code-for-class cpp-class) cpp-out))))
(defun construct-and-load-function-definition-for-class (cpp-class) (defun construct-and-load-function-definition-for-class (cpp-class)
"Generate SLK construct and load function. This function needs to be used "Generate SLK construct and load function. This function needs to be used to
to load pointers to polymorphic types. Raise `SLK-ERROR' if an unsupported or load pointers to polymorphic types. Raise `SLK-ERROR' if an unsupported or
invalid class definition is encountered during code generation. Note that the invalid class definition is encountered during code generation. Note that the
code generation expects the declarations and definitions to be in `slk` code generation expects the declarations and definitions to be in `slk`
namespace." namespace."
(check-type cpp-class lcp::cpp-class) (check-type cpp-class lcp::cpp-class)
@ -340,7 +342,7 @@ namespace."
;;; CPP-ENUM serialization generation ;;; CPP-ENUM serialization generation
(defun save-function-declaration-for-enum (cpp-enum) (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." generation expects the declarations and definitions to be in `slk` namespace."
(check-type cpp-enum lcp::cpp-enum) (check-type cpp-enum lcp::cpp-enum)
(let ((self-arg (let ((self-arg
@ -352,16 +354,16 @@ generation expects the declarations and definitions to be in `slk` namespace."
(with-output-to-string (s) (with-output-to-string (s)
(write-line "uint8_t enum_value;" s) (write-line "uint8_t enum_value;" s)
(lcp::with-cpp-block-output (s :name "switch (self)") (lcp::with-cpp-block-output (s :name "switch (self)")
(loop for enum-value in (lcp::cpp-enum-values cpp-enum) (loop :for enum-value :in (lcp::cpp-enum-values cpp-enum)
and enum-ix from 0 do :and enum-ix :from 0 :do
(format s "case ~A::~A: enum_value = ~A; break;" (format s "case ~A::~A: enum_value = ~A; break;"
(lcp::cpp-type-decl cpp-enum) (lcp::cpp-type-decl cpp-enum)
(lcp::cpp-enumerator-name enum-value) enum-value
enum-ix))) enum-ix)))
(write-line "slk::Save(enum_value, builder);" s))) (write-line "slk::Save(enum_value, builder);" s)))
(defun save-function-definition-for-enum (cpp-enum) (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." declarations and definitions to be in `slk` namespace."
(check-type cpp-enum lcp::cpp-enum) (check-type cpp-enum lcp::cpp-enum)
(with-output-to-string (cpp-out) (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)))) (write-line (save-function-code-for-enum cpp-enum) cpp-out))))
(defun load-function-declaration-for-enum (cpp-enum) (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." generation expects the declarations and definitions to be in `slk` namespace."
(check-type cpp-enum lcp::cpp-enum) (check-type cpp-enum lcp::cpp-enum)
(let ((self-arg (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 "uint8_t enum_value;" s)
(write-line "slk::Load(&enum_value, reader);" s) (write-line "slk::Load(&enum_value, reader);" s)
(lcp::with-cpp-block-output (s :name "switch (enum_value)") (lcp::with-cpp-block-output (s :name "switch (enum_value)")
(loop for enum-value in (lcp::cpp-enum-values cpp-enum) (loop :for enum-value :in (lcp::cpp-enum-values cpp-enum)
and enum-ix from 0 do :and enum-ix :from 0 :do
(format s "case static_cast<uint8_t>(~A): *self = ~A::~A; break;" (format s "case static_cast<uint8_t>(~A): *self = ~A::~A; break;"
enum-ix enum-ix
(lcp::cpp-type-decl cpp-enum) (lcp::cpp-type-decl cpp-enum)
(lcp::cpp-enumerator-name enum-value))) enum-value))
(write-line "default: throw slk::SlkDecodeException(\"Trying to load unknown enum value!\");" s)))) (write-line "default: throw slk::SlkDecodeException(\"Trying to load unknown enum value!\");" s))))
(defun load-function-definition-for-enum (cpp-enum) (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." declarations and definitions to be in `slk` namespace."
(check-type cpp-enum lcp::cpp-enum) (check-type cpp-enum lcp::cpp-enum)
(with-output-to-string (cpp-out) (with-output-to-string (cpp-out)

131
src/lisp/test.lisp
View File

@ -30,19 +30,33 @@
(in-package #:lcp.test) (in-package #:lcp.test)
(defun same-type-test (a b) (defun same-type-test (a b)
"Test whether A and B are the same C++ type under LCP::CPP-TYPE=." "Test whether two CPP-TYPE designators, A and B, designate CPP-TYPE= CPP-TYPE
(is a b :test #'lcp::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) (defun parse-test (type-decl cpp-type)
"Test whether TYPE-DECL parses as the C++ type designated by 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 (is (lcp::parse-cpp-type-declaration type-decl) cpp-type
:test #'lcp::cpp-type=)) :test #'lcp::cpp-type=))
(defun decl-test (type-decl cpp-type &key (type-params t) (namespace t)) (defun fail-parse-test (type-decl)
"Test whether the C++ type designated by CPP-TYPE prints as TYPE-DECL." "Test whether TYPE-DECL fails to parse."
(is (lcp::cpp-type-decl cpp-type (is (lcp::parse-cpp-type-declaration type-decl) nil))
:type-params type-params
:namespace namespace) (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)) type-decl))
(defun different-parse-test (type-decl1 type-decl2) (defun different-parse-test (type-decl1 type-decl2)
@ -50,21 +64,28 @@
(lcp::parse-cpp-type-declaration type-decl2) (lcp::parse-cpp-type-declaration type-decl2)
:test #'lcp::cpp-type=)) :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" (subtest "designators"
(mapc (lambda (sym) (mapc (lambda (name)
(let ((type (lcp::make-cpp-primitive-type sym))) (same-type-test name name)
(same-type-test sym type) (same-type-test (string-downcase name) name)
(same-type-test (string-downcase sym) type) (different-type-test (string-upcase name) name)
(same-type-test (string-upcase sym) type) (different-type-test (string-capitalize name) name)
(same-type-test (string-capitalize sym) type) (same-type-test (make-symbol (string name)) name)
(same-type-test (intern (string sym)) type) (same-type-test (make-symbol (string-downcase name)) name)
(same-type-test (intern (string-downcase sym)) type) (same-type-test (make-symbol (string-upcase name)) name)
(same-type-test (intern (string-upcase sym)) type) (same-type-test (make-symbol (string-capitalize name)) name)
(same-type-test (intern (string-capitalize sym)) type) (same-type-test
(same-type-test (lcp::make-cpp-primitive-type sym) (lcp::make-cpp-type (string-downcase name)) name)
type))) (different-type-test
lcp::+cpp-primitive-type-keywords+) (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) (mapc (lambda (sym)
(let ((type (lcp::make-cpp-type "MyClass"))) (let ((type (lcp::make-cpp-type "MyClass")))
(same-type-test sym type))) (same-type-test sym type)))
@ -78,26 +99,24 @@
(parse-test "char *" (parse-test "char *"
(lcp::make-cpp-type "*" :type-args '(: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" (parse-test "::my_namespace::EnclosingClass::Thing"
(lcp::make-cpp-type "Thing" (lcp::make-cpp-type
:namespace '("" "my_namespace") "Thing"
:enclosing-class "EnclosingClass"))) :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" (subtest "printing"
(decl-test "pair<T1, T2>" (decl-test "pair<T1, T2>"
@ -118,7 +137,7 @@
(decl-test "pair" (decl-test "pair"
(lcp::make-cpp-type (lcp::make-cpp-type
"pair" :type-params '("TIntegral1" "TIntegral2")) "pair" :type-params '("TIntegral1" "TIntegral2"))
:type-params nil)) :type-params-p nil))
(subtest "finding defined enums" (subtest "finding defined enums"
(let ((lcp::*cpp-classes* nil) (let ((lcp::*cpp-classes* nil)
@ -150,19 +169,7 @@
(ok (not (lcp::find-cpp-enum "my_namespace::NonExistent"))) (ok (not (lcp::find-cpp-enum "my_namespace::NonExistent")))
(ok (not (lcp::find-cpp-enum "::NonExistent")))))) (ok (not (lcp::find-cpp-enum "::NonExistent"))))))
(deftest "unsupported" (deftest "util"
(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"
(subtest "fnv1a64" (subtest "fnv1a64"
(is (lcp::fnv1a64-hash-string "query::plan::LogicalOperator") (is (lcp::fnv1a64-hash-string "query::plan::LogicalOperator")
#xCF6E3316FE845113) #xCF6E3316FE845113)
@ -242,7 +249,7 @@
(:serialize (:slk :ignore-other-base-classes t)))) (:serialize (:slk :ignore-other-base-classes t))))
"void Save(const Derived &self, slk::Builder *builder)") "void Save(const Derived &self, slk::Builder *builder)")
(undefine-cpp-types) (undefine-cpp-types)
;; Unsupported template classes ;; Unsupported class templates
(is-error (lcp.slk:save-function-declaration-for-class (is-error (lcp.slk:save-function-declaration-for-class
(lcp:define-class (derived t-param) (base) (lcp:define-class (derived t-param) (base)
())) ()))
@ -513,22 +520,22 @@
slk::Load(&self->derived_member, reader); slk::Load(&self->derived_member, reader);
}")) }"))
(undefine-cpp-types) (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)))) ((base-member :bool))))
(derived-class (lcp:define-struct derived (base) (derived-class (lcp:define-struct derived (base)
((derived-member :int64_t))))) ((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) 'lcp.slk:slk-error)
(is-error (lcp.slk:save-function-definition-for-class derived-class) (is-error (lcp.slk:save-function-definition-for-class derived-class)
'lcp.slk:slk-error)) 'lcp.slk:slk-error))
(undefine-cpp-types) (undefine-cpp-types)
(let ((base-class (lcp:define-struct base () (let ((base-class (lcp:define-struct base ()
((base-member :bool)))) ((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))))) ((derived-member :int64_t)))))
(is-error (lcp.slk:save-function-definition-for-class base-class) (is-error (lcp.slk:save-function-definition-for-class base-class)
'lcp.slk:slk-error) '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)) 'lcp.slk:slk-error))
(undefine-cpp-types) (undefine-cpp-types)
@ -797,7 +804,7 @@
(:clone)))) (:clone))))
(is-error (lcp.clone:clone-function-definition-for-class child-class) (is-error (lcp.clone:clone-function-definition-for-class child-class)
'lcp.clone:clone-error)) 'lcp.clone:clone-error))
;; template classes ;; Class templates
(undefine-cpp-types) (undefine-cpp-types)
(let ((container-class (lcp:define-class (my-container t-element) () (let ((container-class (lcp:define-class (my-container t-element) ()
((data "TElement *") ((data "TElement *")
@ -962,7 +969,7 @@
(single-member-test (member "std::shared_ptr<Klondike>") (single-member-test (member "std::shared_ptr<Klondike>")
"object.member_ = member_ ? member_->Clone() : nullptr;")) "object.member_ = member_ ? member_->Clone() : nullptr;"))
(subtest "enum" (subtest "enum"
(lcp:define-enum enum '(val1 val2 val3)) (lcp:define-enum enum (val1 val2 val3))
(single-member-test (member "Enum") (single-member-test (member "Enum")
"object.member_ = member_;")) "object.member_ = member_;"))
(subtest "builtin c++ types" (subtest "builtin c++ types"
@ -992,5 +999,3 @@
(single-member-test (member "UnknownClass") (single-member-test (member "UnknownClass")
"object.member_ = member_;") "object.member_ = member_;")
(undefine-cpp-types)))) (undefine-cpp-types))))

1487
src/lisp/types.lisp
View File

File diff suppressed because it is too large Load Diff

78
src/lisp/util.lisp Normal file
View File

@ -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))

38
src/query/frontend/ast/ast.lcp
View File

@ -370,17 +370,16 @@ cpp<#
`(lcp:define-class ,op (binary-operator) `(lcp:define-class ,op (binary-operator)
() ()
(:public (:public
(let ((cpp-name (lcp::cpp-type-name ',op))) #>cpp
#>cpp DEFVISITABLE(ExpressionVisitor<TypedValue>);
DEFVISITABLE(ExpressionVisitor<TypedValue>); DEFVISITABLE(ExpressionVisitor<void>);
DEFVISITABLE(ExpressionVisitor<void>); bool Accept(HierarchicalTreeVisitor &visitor) override {
bool Accept(HierarchicalTreeVisitor &visitor) override { if (visitor.PreVisit(*this)) {
if (visitor.PreVisit(*this)) { expression1_->Accept(visitor) && expression2_->Accept(visitor);
expression1_->Accept(visitor) && expression2_->Accept(visitor);
}
return visitor.PostVisit(*this);
} }
cpp<#)) return visitor.PostVisit(*this);
}
cpp<#)
(:protected (:protected
#>cpp #>cpp
using BinaryOperator::BinaryOperator; using BinaryOperator::BinaryOperator;
@ -402,17 +401,16 @@ cpp<#
`(lcp:define-class ,op (unary-operator) `(lcp:define-class ,op (unary-operator)
() ()
(:public (:public
(let ((cpp-name (lcp::cpp-type-name ',op))) #>cpp
#>cpp DEFVISITABLE(ExpressionVisitor<TypedValue>);
DEFVISITABLE(ExpressionVisitor<TypedValue>); DEFVISITABLE(ExpressionVisitor<void>);
DEFVISITABLE(ExpressionVisitor<void>); bool Accept(HierarchicalTreeVisitor &visitor) override {
bool Accept(HierarchicalTreeVisitor &visitor) override { if (visitor.PreVisit(*this)) {
if (visitor.PreVisit(*this)) { expression_->Accept(visitor);
expression_->Accept(visitor);
}
return visitor.PostVisit(*this);
} }
cpp<#)) return visitor.PostVisit(*this);
}
cpp<#)
(:protected (:protected
#>cpp #>cpp
using UnaryOperator::UnaryOperator; using UnaryOperator::UnaryOperator;