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-compile
${CMAKE_SOURCE_DIR}/src/lisp/package.lisp
${CMAKE_SOURCE_DIR}/src/lisp/names.lisp
${CMAKE_SOURCE_DIR}/src/lisp/types.lisp
${CMAKE_SOURCE_DIR}/src/lisp/clone.lisp
${CMAKE_SOURCE_DIR}/src/lisp/code-gen.lisp
@ -54,6 +55,7 @@ macro(define_add_lcp name main_src_files generated_lcp_files)
${CMAKE_SOURCE_DIR}/src/lisp/lcp.asd
${CMAKE_SOURCE_DIR}/src/lisp/lcp-compile
${CMAKE_SOURCE_DIR}/src/lisp/package.lisp
${CMAKE_SOURCE_DIR}/src/lisp/names.lisp
${CMAKE_SOURCE_DIR}/src/lisp/types.lisp
${CMAKE_SOURCE_DIR}/src/lisp/clone.lisp
${CMAKE_SOURCE_DIR}/src/lisp/code-gen.lisp

227
src/lisp/clone.lisp
View File

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

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

4
src/lisp/lcp.asd
View File

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

323
src/lisp/lcp.lisp
View File

@ -4,69 +4,64 @@
(in-package #:lcp)
(named-readtables:in-readtable lcp-syntax)
(defvar +vim-read-only+ "vim: readonly")
(defvar +emacs-read-only+ "-*- buffer-read-only: t; -*-")
(defvar *generating-cpp-impl-p* nil
"T if we are currently writing the .cpp file.")
(defun fnv1a64-hash-string (string)
"Produce (UNSIGNED-BYTE 64) hash of the given STRING using FNV-1a algorithm.
See https://en.wikipedia.org/wiki/Fowler_Noll_Vo_hash."
(check-type string string)
(let ((hash 14695981039346656037) ;; offset basis
(prime 1099511628211))
(declare (type (unsigned-byte 64) hash prime))
(loop for c across string do
(setf hash (mod (* (boole boole-xor hash (char-code c)) prime)
(expt 2 64) ;; Fit to 64bit
)))
hash))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; C++ code generation
(defun cpp-enum-definition (cpp-enum)
"Get C++ style `CPP-ENUM' definition as a string."
(declare (type cpp-enum cpp-enum))
(check-type cpp-enum cpp-enum)
(with-output-to-string (s)
(when (cpp-type-documentation cpp-enum)
(write-line (cpp-documentation (cpp-type-documentation cpp-enum)) s))
(with-cpp-block-output (s :name (format nil "enum class ~A" (cpp-type-name cpp-enum))
:semicolonp t)
(format s "~{ ~A~^,~%~}~%" (mapcar #'cpp-enumerator-name (cpp-enum-values cpp-enum))))))
(format s "~{ ~A~^,~%~}~%" (cpp-enum-values cpp-enum)))))
(defun cpp-member-declaration (cpp-member &key struct)
(defun cpp-member-declaration (cpp-member)
"Get C++ style `CPP-MEMBER' declaration as a string."
(declare (type cpp-member cpp-member)
(type boolean struct))
(let ((type-name (cpp-type-name (cpp-member-type cpp-member))))
(check-type cpp-member cpp-member)
(let ((type-name (cpp-type-decl (cpp-member-type cpp-member))))
(with-output-to-string (s)
(when (cpp-member-documentation cpp-member)
(write-line (cpp-documentation (cpp-member-documentation cpp-member)) s))
(if (cpp-member-initval cpp-member)
(format s "~A ~A{~A};" type-name
(cpp-member-name cpp-member :struct struct) (cpp-member-initval cpp-member))
(format s "~A ~A;" type-name (cpp-member-name cpp-member :struct struct))))))
(format s "~A ~A{~A};"
type-name
(cpp-member-name cpp-member)
(cpp-member-initval cpp-member))
(format s "~A ~A;"
type-name
(cpp-member-name cpp-member))))))
(defun cpp-member-reader-definition (cpp-member)
"Get C++ style `CPP-MEMBER' getter (reader) function."
(declare (type cpp-member cpp-member))
(if (typep (cpp-member-type cpp-member) 'cpp-primitive-type-keywords)
(format nil "auto ~A() const { return ~A; }" (cpp-member-name cpp-member :struct t) (cpp-member-name cpp-member))
(format nil "const auto &~A() const { return ~A; }" (cpp-member-name cpp-member :struct t) (cpp-member-name cpp-member))))
(check-type cpp-member cpp-member)
(if (cpp-type-primitive-p (cpp-member-type cpp-member))
(format nil "auto ~A() const { return ~A; }"
(cpp-member-reader-name cpp-member)
(cpp-member-name cpp-member))
(format nil "const auto &~A() const { return ~A; }"
(cpp-member-reader-name cpp-member)
(cpp-member-name cpp-member))))
(defun cpp-template (type-params &optional stream)
"Generate C++ template declaration from provided TYPE-PARAMS. If STREAM is
NIL, returns a string."
(format stream "template <~{class ~A~^,~^ ~}>"
(mapcar #'cpp-type-name type-params)))
(format stream "template <~{class ~A~^,~^ ~}>" type-params))
(defun type-info-declaration-for-class (cpp-class)
(assert (and (not (cpp-type-type-params cpp-class))
(not (cpp-type-type-args cpp-class))))
(assert (cpp-type-simple-class-p cpp-class))
(with-output-to-string (s)
(write-line "static const utils::TypeInfo kType;" s)
(let* ((type-info-basep (type-info-opts-base (cpp-class-type-info-opts cpp-class)))
(virtual (if (and (or type-info-basep (not (cpp-class-super-classes cpp-class)))
(direct-subclasses-of cpp-class))
(let* ((type-info-basep (type-info-opts-base
(cpp-class-type-info-opts cpp-class)))
(virtual (if (and (or type-info-basep
(not (cpp-class-super-classes cpp-class)))
(cpp-class-direct-subclasses cpp-class))
"virtual"
""))
(override (if (and (not type-info-basep)
@ -77,64 +72,66 @@ NIL, returns a string."
virtual override))))
(defun type-info-definition-for-class (cpp-class)
(assert (and (not (cpp-type-type-params cpp-class))
(not (cpp-type-type-args cpp-class))))
(assert (cpp-type-simple-class-p cpp-class))
(with-output-to-string (s)
(let ((super-classes (when (not (type-info-opts-base (cpp-class-type-info-opts cpp-class)))
(let ((super-classes (when (not (type-info-opts-base
(cpp-class-type-info-opts cpp-class)))
(cpp-class-super-classes cpp-class))))
(when (type-info-opts-ignore-other-base-classes (cpp-class-type-info-opts cpp-class))
(when (type-info-opts-ignore-other-base-classes
(cpp-class-type-info-opts cpp-class))
(setf super-classes (list (first super-classes))))
(when (> (length super-classes) 1)
(error "Unable to generate TypeInfo for class '~A' due to multiple inheritance!"
(cpp-type-base-name cpp-class)))
(flet ((get-super-type-info (super)
(let ((super-class (find-cpp-class super)))
(format nil "&~A::kType"
(if super-class
(cpp-type-decl super-class)
(cpp-type-name super))))))
(format s "const utils::TypeInfo ~A::kType{0x~XULL, \"~A\", ~A};~%"
(if *generating-cpp-impl-p*
(cpp-type-name cpp-class)
;; Use full type declaration if class definition
;; isn't inside the .cpp file.
(cpp-type-decl cpp-class))
;; Use full type declaration for hash
(fnv1a64-hash-string (cpp-type-decl cpp-class))
(cpp-type-name cpp-class)
(if super-classes (get-super-type-info (first super-classes)) "nullptr"))))))
(cpp-type-name cpp-class)))
(format s "const utils::TypeInfo ~A::kType{0x~XULL, \"~A\", ~A};~%"
(if *generating-cpp-impl-p*
(cpp-type-name cpp-class)
;; Use full type declaration if class definition
;; isn't inside the .cpp file.
(cpp-type-decl cpp-class))
;; Use full type declaration for hash
(fnv1a64-hash-string (cpp-type-decl cpp-class))
(cpp-type-name cpp-class)
(if super-classes
(format nil "&~A::kType"
(cpp-type-decl (first super-classes)))
"nullptr")))))
(defun cpp-class-definition (cpp-class)
"Get C++ definition of the CPP-CLASS as a string."
(declare (type cpp-class cpp-class))
(check-type cpp-class cpp-class)
(flet ((cpp-class-members-scoped (scope)
(remove-if (lambda (m) (not (eq scope (cpp-member-scope m))))
(cpp-class-members cpp-class)))
(member-declaration (member)
(cpp-member-declaration member :struct (cpp-class-structp cpp-class))))
(cpp-member-declaration member)))
(with-output-to-string (s)
(terpri s)
(when (cpp-type-documentation cpp-class)
(write-line (cpp-documentation (cpp-type-documentation cpp-class)) s))
(when (cpp-type-type-params cpp-class)
(when (cpp-type-class-template-p cpp-class)
(cpp-template (cpp-type-type-params cpp-class) s))
(if (cpp-class-structp cpp-class)
(write-string "struct " s)
(write-string "class " s))
(format s "~A" (cpp-type-name cpp-class))
(when (cpp-class-super-classes cpp-class)
(format s " : ~{public ~A~^, ~}"
(mapcar #'cpp-type-name (cpp-class-super-classes cpp-class))))
(let ((super-classes (cpp-class-super-classes cpp-class)))
(when super-classes
(format s " : ~{public ~A~^, ~}"
(mapcar #'cpp-type-decl super-classes))))
(with-cpp-block-output (s :semicolonp t)
(let ((reader-members (remove-if (complement #'cpp-member-reader)
(cpp-class-members cpp-class))))
(when (or (cpp-class-public cpp-class) (cpp-class-members-scoped :public) reader-members
;; We at least have public TypeInfo object for non-template classes.
(not (cpp-type-type-params cpp-class)))
(when (or (cpp-class-public cpp-class)
(cpp-class-members-scoped :public)
reader-members
;; We at least have public TypeInfo object for non-template
;; classes.
(not (cpp-type-class-template-p cpp-class)))
(unless (cpp-class-structp cpp-class)
(write-line " public:" s))
(unless (cpp-type-type-params cpp-class)
;; Skip generating TypeInfo for template classes.
;; Skip generating TypeInfo for class templates.
(unless (cpp-type-class-template-p cpp-class)
(write-line (type-info-declaration-for-class cpp-class) s))
(format s "~%~{~A~%~}" (mapcar #'cpp-code (cpp-class-public cpp-class)))
(format s "~{~%~A~}~%" (mapcar #'cpp-member-reader-definition reader-members))
@ -152,9 +149,9 @@ NIL, returns a string."
(format s "~{~A~%~}" (mapcar #'cpp-code (cpp-class-private cpp-class)))
(format s "~{ ~%~A~}~%"
(mapcar #'member-declaration (cpp-class-members-scoped :private)))))
;; Define the TypeInfo object. Relies on the fact that *CPP-IMPL* is
;; Define the TypeInfo object. Relies on the fact that *CPP-IMPL* is
;; processed later.
(unless (cpp-type-type-params cpp-class)
(unless (cpp-type-class-template-p cpp-class)
(let ((typeinfo-def (type-info-definition-for-class cpp-class)))
(if *generating-cpp-impl-p*
(write-line typeinfo-def s)
@ -164,13 +161,13 @@ NIL, returns a string."
"Generate a C++ top level function declaration named NAME as a string. ARGS
is a list of (variable type) function arguments. RETURNS is the return type of
the function. TYPE-PARAMS is a list of names for template argments"
(declare (type string name))
(declare (type string returns))
(check-type name string)
(check-type returns string)
(let ((template (if type-params (cpp-template type-params) ""))
(args (format nil "~:{~A ~A~:^, ~}"
(mapcar (lambda (name-and-type)
(list (cpp-type-name (second name-and-type))
(cpp-variable-name (first name-and-type))))
(list (ensure-typestring (second name-and-type))
(ensure-namestring-for-variable (first name-and-type))))
args))))
(raw-cpp-string
#>cpp
@ -186,19 +183,21 @@ CLASS. ARGS is a list of (variable type) arguments to method. RETURNS is the
return type of the function. When INLINE is set to NIL, generates a
declaration to be used outside of class definition. Remaining keys are flags
which generate the corresponding C++ keywords."
(declare (type cpp-class class)
(type string method-name))
(check-type class cpp-class)
(check-type method-name string)
(let* ((type-params (cpp-type-type-params class))
(template (if (or inline (not type-params)) "" (cpp-template type-params)))
(static/virtual (cond
((and inline static) "static")
((and inline virtual) "virtual")
(t "")))
(namespace (if inline "" (format nil "~A::" (cpp-type-decl class :namespace nil))))
(namespace
(if inline "" (format nil "~A::" (cpp-type-decl
class :namespacep nil))))
(args (format nil "~:{~A ~A~:^, ~}"
(mapcar (lambda (name-and-type)
(list (cpp-type-name (second name-and-type))
(cpp-variable-name (first name-and-type))))
(list (ensure-typestring (second name-and-type))
(ensure-namestring-for-variable (first name-and-type))))
args)))
(const (if const "const" ""))
(override (if (and override inline) "override" ""))
@ -229,22 +228,20 @@ which generate the corresponding C++ keywords."
(null "")
(otherwise (error "Unknown conversion to C++ for ~S" (type-of cpp)))))
(defun count-newlines (stream &key stop-position)
(loop for pos = (file-position stream)
and char = (read-char stream nil nil)
until (or (not char) (and stop-position (> pos stop-position)))
when (char= #\Newline char) count it))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; The LCP Driver
(defvar +vim-read-only+ "vim: readonly")
(defvar +emacs-read-only+ "-*- buffer-read-only: t; -*-")
(defvar *cpp-namespaces* nil
"Stack of C++ namespaces we are generating the code in.")
(defmacro namespace (name)
"Push the NAME to currently set namespaces."
(declare (type symbol name))
(let ((cpp-namespace (cpp-variable-name name)))
(check-type name symbol)
(let ((cpp-namespace (cpp-name-for-variable name)))
`(progn
(push ,cpp-namespace *cpp-namespaces*)
(make-raw-cpp
@ -254,8 +251,9 @@ which generate the corresponding C++ keywords."
(pop *cpp-namespaces*)
#>cpp } cpp<#)
(defvar *cpp-impl* nil "List of (namespace . C++ code) pairs that should be
written in the implementation (.cpp) file.")
(defvar *cpp-impl* nil
"List of (namespace . C++ code) pairs that should be written in the
implementation (.cpp) file.")
(defun in-impl (&rest args)
(let ((namespaces (reverse *cpp-namespaces*)))
@ -263,139 +261,34 @@ which generate the corresponding C++ keywords."
(append *cpp-impl* (mapcar (lambda (cpp) (cons namespaces cpp))
args)))))
(defmacro define-rpc (name request response)
(declare (type list request response))
(assert (eq :request (car request)))
(assert (eq :response (car response)))
(flet ((decl-type-info (class-name))
(def-constructor (class-name members)
(let ((full-constructor
(let ((init-members (remove-if (lambda (slot-def)
;; TODO: proper initarg
(let ((initarg (member :initarg slot-def)))
(and initarg (null (second initarg)))))
members)))
(with-output-to-string (s)
(when init-members
(format s "~A ~A(~:{~A ~A~:^, ~}) : ~:{~A(~A)~:^, ~} {}"
(if (= 1 (list-length init-members)) "explicit" "")
class-name
(mapcar (lambda (member)
(list (cpp-type-name (second member))
(cpp-variable-name (first member))))
init-members)
(mapcar (lambda (member)
(let ((var (cpp-variable-name (first member)))
(movep (eq :move (second (member :initarg member)))))
(list var (if movep
(format nil "std::move(~A)" var)
var))))
init-members)))))))
#>cpp
${class-name}() {}
${full-constructor}
cpp<#)))
(let* ((req-sym (intern (format nil "~A-~A" name 'req)))
(req-name (cpp-type-name req-sym))
(res-sym (intern (format nil "~A-~A" name 'res)))
(res-name (cpp-type-name res-sym))
(rpc-name (format nil "~ARpc" (cpp-type-name name)))
(rpc-decl
#>cpp
using ${rpc-name} = communication::rpc::RequestResponse<${req-name}, ${res-name}>;
cpp<#))
`(cpp-list
(define-struct ,req-sym ()
,@(cdr request)
(:public
,(decl-type-info req-name)
,(def-constructor req-name (second request)))
(:serialize (:slk)))
(let ((req-class (find-cpp-class ',req-sym)))
(unless (lcp.slk::save-extra-args req-class)
(push ,(progn
#>cpp
static void Save(const ${req-name} &self, slk::Builder *builder);
cpp<#)
(cpp-class-public req-class))
(in-impl
,(progn
#>cpp
void ${req-name}::Save(const ${req-name} &self, slk::Builder *builder) {
slk::Save(self, builder);
}
cpp<#)))
(unless (lcp.slk::load-extra-args req-class)
(push ,(progn #>cpp
static void Load(${req-name} *self, slk::Reader *reader);
cpp<#)
(cpp-class-public req-class))
(in-impl
,(progn
#>cpp
void ${req-name}::Load(${req-name} *self, slk::Reader *reader) {
slk::Load(self, reader);
}
cpp<#))))
(define-struct ,res-sym ()
,@(cdr response)
(:public
,(decl-type-info res-name)
,(def-constructor res-name (second response)))
(:serialize (:slk)))
(let ((res-class (find-cpp-class ',res-sym)))
(unless (lcp.slk::save-extra-args res-class)
(push ,(progn
#>cpp
static void Save(const ${res-name} &self, slk::Builder *builder);
cpp<#)
(cpp-class-public res-class))
(in-impl
,(progn
#>cpp
void ${res-name}::Save(const ${res-name} &self, slk::Builder *builder) {
slk::Save(self, builder);
}
cpp<#)))
(unless (lcp.slk::load-extra-args res-class)
(push ,(progn #>cpp
static void Load(${res-name} *self, slk::Reader *reader);
cpp<#)
(cpp-class-public res-class))
(in-impl
,(progn
#>cpp
void ${res-name}::Load(${res-name} *self, slk::Reader *reader) {
slk::Load(self, reader);
}
cpp<#))))
,rpc-decl))))
(defun read-lcp (filepath)
"Read the FILEPATH and return a list of C++ meta information that should be
formatted and output."
"Read the file FILEPATH and return a list of C++ meta information that should
be formatted and output."
(with-open-file (in-stream filepath)
(let ((*readtable* (named-readtables:find-readtable 'lcp-syntax))
(stream-pos 0))
(handler-case
(loop for form = (read-preserving-whitespace in-stream nil 'eof)
until (eq form 'eof)
for res = (handler-case (eval form)
(error (err)
(file-position in-stream 0) ;; start of stream
(error "~%~A:~A: error:~2%~A~2%in:~2%~A"
(uiop:native-namestring filepath)
(count-newlines in-stream :stop-position (1+ stream-pos))
err form)))
do (setf stream-pos (file-position in-stream))
when (typep res '(or raw-cpp cpp-type cpp-list))
collect res)
(loop :for form := (read-preserving-whitespace in-stream nil 'eof)
:until (eq form 'eof)
:for res := (handler-case (eval form)
(error (err)
;; Seek to the start of the stream.
(file-position in-stream 0)
(error "~%~A:~A: error:~2%~A~2%in:~2%~A"
(uiop:native-namestring filepath)
(count-newlines
in-stream
:stop-position (1+ stream-pos))
err form)))
:do (setf stream-pos (file-position in-stream))
:when (typep res '(or raw-cpp cpp-type cpp-list))
:collect res)
(end-of-file ()
(file-position in-stream 0) ;; start of stream
;; Seek to the start of the stream.
(file-position in-stream 0)
(error "~%~A:~A:error: READ error, did you forget a closing ')'?"
(uiop:native-namestring filepath)
(count-newlines in-stream
:stop-position (1+ stream-pos))))))))
(count-newlines in-stream :stop-position (1+ stream-pos))))))))
(defun process-file (lcp-file &key slk-serialize)
"Process a LCP-FILE and write the output to .hpp file in the same directory."
@ -443,7 +336,7 @@ formatted and output."
(cpp-class
(format out "~A;~%" (lcp.slk:save-function-declaration-for-class type-for-slk))
(when (or (cpp-class-super-classes type-for-slk)
(direct-subclasses-of type-for-slk))
(cpp-class-direct-subclasses type-for-slk))
(format out "~A;~%" (lcp.slk:construct-and-load-function-declaration-for-class type-for-slk)))
(unless (cpp-class-abstractp type-for-slk)
(format out "~A;~%" (lcp.slk:load-function-declaration-for-class type-for-slk))))
@ -476,7 +369,7 @@ formatted and output."
;; Top level functions
(write-line (lcp.slk:save-function-definition-for-class cpp-type) out)
(when (or (cpp-class-super-classes cpp-type)
(direct-subclasses-of cpp-type))
(cpp-class-direct-subclasses cpp-type))
(format out "~A;~%" (lcp.slk:construct-and-load-function-definition-for-class cpp-type)))
(unless (cpp-class-abstractp cpp-type)
(write-line (lcp.slk:load-function-definition-for-class cpp-type) out)))

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

131
src/lisp/test.lisp
View File

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

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