diff --git a/doc/cffi-manual.texinfo b/doc/cffi-manual.texinfo index a941647..70c2900 100644 --- a/doc/cffi-manual.texinfo +++ b/doc/cffi-manual.texinfo @@ -251,6 +251,10 @@ Functions * defcfun:: Defines a foreign function. * foreign-funcall:: Performs a call to a foreign function. * foreign-funcall-pointer:: Performs a call through a foreign pointer. +* translate-camelcase-name:: Converts a camelCase foreign name to/from a Lisp name. +* translate-name-from-foreign:: Converts a foreign name to a Lisp name. +* translate-name-to-foreign:: Converts a Lisp name to a foreign name. +* translate-underscore-separated-name:: Converts an underscore_separated foreign name to/from a Lisp name. Libraries @@ -5045,6 +5049,10 @@ Dictionary * defcfun:: * foreign-funcall:: * foreign-funcall-pointer:: +* translate-camelcase-name:: +* translate-name-from-foreign:: +* translate-name-to-foreign:: +* translate-underscore-separated-name:: @end menu @c @node Calling Foreign Functions @@ -5268,7 +5276,7 @@ CFFI> (foreign-funcall "printf" :string (format nil "%s: %d.~%") @c FOREIGN-FUNCALL-POINTER @page -@node foreign-funcall-pointer, , foreign-funcall, Functions +@node foreign-funcall-pointer, translate-camelcase-name, foreign-funcall, Functions @heading foreign-funcall-pointer @subheading Syntax @Macro{foreign-funcall-pointer pointer options &rest arguments @res{} return-value} @@ -5329,6 +5337,219 @@ CFFI> (foreign-funcall-pointer (foreign-symbol-pointer "abs") () @c =================================================================== +@c TRANSLATE-CAMELCASE-NAME + +@page +@node translate-camelcase-name, translate-name-from-foreign, foreign-funcall-pointer, Functions +@heading translate-camelcase-name +@subheading Syntax +@Function{translate-camelcase-name name &key upper-initial-p special-words @res{} return-value} + +@subheading Arguments and Values + +@table @var +@item name +Either a symbol or a string. + +@item upper-initial-p +A generalized boolean. + +@item special words +A list of strings. + +@item return-value +If @var{name} is a symbol, this is a string, and vice versa. +@end table + +@subheading Description +@code{translate-camelcase-name} is a helper function for +specializations of +@code{translate-name-from-foreign} and +@code{translate-name-to-foreign}. It handles the common +case of converting between foreign camelCase names and lisp +names. @var{upper-initial-p} indicates whether the first letter of the +foreign name should be uppercase. @var{special-words} is a list of +strings that should be treated atomically in tranlation. This list is +case-sensitive. + +@subheading Examples + +@lisp +CFFI> (translate-camelcase-name some-xml-function) +@result{} "someXmlFunction" +CFFI> (translate-camelcase-name some-xml-function :upper-initial-p t) +@result{} "SomeXmlFunction" +CFFI> (translate-camelcase-name some-xml-function :special-words '("XML")) +@result{} "someXMLFunction" +CFFI> (translate-camelcase-name "someXMLFunction") +@result{} SOME-X-M-L-FUNCTION +CFFI> (translate-camelcase-name "someXMLFunction" :special-words '("XML")) +@result{} SOME-XML-FUNCTION +@end lisp + +@subheading See Also +@seealso{translate-name-from-foreign} @* +@seealso{translate-name-to-foreign} @* +@seealso{translate-underscore-separated-name} + + +@c =================================================================== +@c TRANSLATE-NAME-FROM-FOREIGN + +@page +@node translate-name-from-foreign, translate-name-to-foreign, translate-camelcase-name, Functions +@heading translate-name-from-foreign +@subheading Syntax +@Function{translate-name-from-foreign foreign-name package &optional varp @res{} symbol} + +@subheading Arguments and Values + +@table @var +@item foreign-name +A string denoting a foreign function. + +@item package +A Lisp package + +@item varp +A generalized boolean. + +@item symbol +The Lisp symbol to be used a function name. +@end table + +@subheading Description +@code{translate-name-from-foreign} is used by @code{@seealso{defcfun}} +to handle the conversion of foreign names to lisp names. By default, +it translates using +@code{@seealso{translate-underscore-separated-name}}. However, you can +create specialized methods on this function to make translating more +closely match the foreign library's naming conventions. + +Specialize @var{package} on some package. This allows other packages +to load libraries with different naming conventions. + +@subheading Examples + +@lisp +CFFI> (defcfun "someXmlFunction" ...) +@result{} SOMEXMLFUNCTION +CFFI> (defmethod translate-name-from-foreign ((spec string) (package +(eql *package*)) &optional varp) + (let ((name (translate-camelcase-name spec))) + (if varp (intern "*~a*" name) name))) +@result{} #))> +CFFI> (defcfun "someXmlFunction" ...) +@result{} SOME-XML-FUNCTION +@end lisp + +@subheading See Also +@seealso{defcfun} @* +@seealso{translate-camelcase-name} @* +@seealso{translate-name-to-foreign} @* +@seealso{translate-underscore-separated-name} + + +@c =================================================================== +@c TRANSLATE-NAME-TO-FOREIGN + +@page +@node translate-name-to-foreign, translate-underscore-separated-name, translate-name-from-foreign, Functions +@heading translate-name-to-foreign +@subheading Syntax +@Function{translate-name-to-foreign lisp-name package &optional varp @res{} string} + +@subheading Arguments and Values + +@table @var +@item lisp-name +A symbol naming the Lisp function to be created. + +@item package +A Lisp package + +@item varp +A generalized boolean. + +@item string +The string representing the foreign function name. +@end table + +@subheading Description +@code{translate-name-to-foreign} is used by @code{@seealso{defcfun}} +to handle the conversion of lisp names to foreign names. By default, +it translates using +@code{@seealso{translate-underscore-separated-name}}. However, you can +create specialized methods on this function to make translating more +closely match the foreign library's naming conventions. + +Specialize @var{package} on some package. This allows other packages +to load libraries with different naming conventions. + +@subheading Examples + +@lisp +CFFI> (defcfun some-xml-function ...) +@result{} "some_xml_function" +CFFI> (defmethod translate-name-to-foreign ((spec symbol) (package +(eql *package*)) &optional varp) + (let ((name (translate-camelcase-name spec))) + (if varp (subseq name 1 (1- (length name))) name))) +@result{} #))> +CFFI> (defcfun some-xml-function ...) +@result{} "someXmlFunction" +@end lisp + +@subheading See Also +@seealso{defcfun} @* +@seealso{translate-camelcase-name} @* +@seealso{translate-name-from-foreign} @* +@seealso{translate-underscore-separated-name} + + +@c =================================================================== +@c TRANSLATE-UNDERSCORE-SEPARATED-NAME + +@page +@node translate-underscore-separated-name, , translate-name-to-foreign, Functions +@heading translate-underscore-separated-name +@subheading Syntax +@Function{translate-underscore-separated-name name @res{} return-value} + +@subheading Arguments and Values + +@table @var +@item name +Either a symbol or a string. + +@item return-value +If @var{name} is a symbol, this is a string, and vice versa. +@end table + +@subheading Description +@code{translate-underscore-separated-name} is a helper function for +specializations of +@code{@seealso{translate-name-from-foreign}} and +@code{@seealso{translate-name-to-foreign}}. It handles the common +case of converting between foreign underscore_separated names and lisp +names. + +@subheading Examples + +@lisp +CFFI> (translate-underscore-separated-name some-xml-function) +@result{} "some_xml_function" +CFFI> (translate-camelcase-name "some_xml_function") +@result{} SOME-XML-FUNCTION +@end lisp + +@subheading See Also +@seealso{translate-name-from-foreign} @* +@seealso{translate-name-to-foreign} @* +@seealso{translate-camelcase-name} + + +@c =================================================================== @c CHAPTER: Libraries @node Libraries, Callbacks, Functions, Top diff --git a/src/functions.lisp b/src/functions.lisp index 6bda2af..e3fb094 100644 --- a/src/functions.lisp +++ b/src/functions.lisp @@ -218,6 +218,86 @@ arguments and does type promotion for the variadic arguments." ;;; present, its name is derived from the other. See the user ;;; documentation for an explanation of the derivation rules. +(defgeneric translate-underscore-separated-name (name) + (:method ((name string)) + (values (intern (canonicalize-symbol-name-case (substitute #\- #\_ name))))) + (:method ((name symbol)) + (substitute #\_ #\- (string-downcase (symbol-name name))))) + +(defun collapse-prefix (l special-words) + (unless (null l) + (multiple-value-bind (newpre skip) (check-prefix l special-words) + (cons newpre (collapse-prefix (nthcdr skip l) special-words))))) + +(defun check-prefix (l special-words) + (let ((pl (loop for i from (1- (length l)) downto 0 + collect (apply #'concatenate 'simple-string (butlast l i))))) + (loop for w in special-words + for p = (position-if #'(lambda (s) (string= s w)) pl) + when p do (return-from check-prefix (values (nth p pl) (1+ p)))) + (values (first l) 1))) + +(defun split-if (test seq &optional (dir :before)) + (remove-if #'(lambda (x) (equal x (subseq seq 0 0))) + (loop for start fixnum = 0 + then (if (eq dir :before) + stop + (the fixnum (1+ (the fixnum stop)))) + while (< start (length seq)) + for stop = (position-if + test seq + :start (if (eq dir :elide) + start + (the fixnum (1+ start)))) + collect (subseq + seq start + (if (and stop (eq dir :after)) + (the fixnum (1+ (the fixnum stop))) + stop)) + while stop))) + +(defgeneric translate-camelcase-name + (name &key upper-initial-p special-words) + (:method ((name string) &key upper-initial-p special-words) + (declare (ignore upper-initial-p)) + (values (intern (reduce #'(lambda (s1 s2) + (concatenate 'simple-string s1 "-" s2)) + (mapcar #'string-upcase + (collapse-prefix + (split-if #'(lambda (ch) + (or (upper-case-p ch) + (digit-char-p ch))) + name) + special-words)))))) + (:method ((name symbol) &key upper-initial-p special-words) + (apply #'concatenate + 'string + (loop for str in (split-if #'(lambda (ch) (eq ch #\-)) + (string name) + :elide) + for first-word-p = t then nil + for e = (member str special-words + :test #'equal :key #'string-upcase) + collect (cond + ((and first-word-p (not upper-initial-p)) + (string-downcase str)) + (e (first e)) + (t (string-capitalize str))))))) + +(defgeneric translate-name-from-foreign (foreign-name package &optional varp) + (:method (foreign-name package &optional varp) + (declare (ignore package)) + (values (intern (format nil (if varp "*~A*" "~A") + (translate-underscore-separated-name foreign-name)))))) + +(defgeneric translate-name-to-foreign (lisp-name package &optional varp) + (:method (lisp-name package &optional varp) + (declare (ignore package)) + (let ((name (translate-underscore-separated-name lisp-name))) + (if varp + (string-trim '(#\*) name) + name)))) + (defun lisp-name (spec &optional varp) (etypecase spec (list (if (keywordp (second spec)) @@ -225,10 +305,7 @@ arguments and does type promotion for the variadic arguments." (if (symbolp (first spec)) (first spec) (lisp-name (second spec) varp)))) - (string (intern - (format nil (if varp "*~A*" "~A") - (canonicalize-symbol-name-case - (substitute #\- #\_ spec))))) + (string (translate-name-from-foreign spec *package* varp)) (symbol spec))) (defun foreign-name (spec &optional varp) @@ -237,11 +314,7 @@ arguments and does type promotion for the variadic arguments." (second spec) (foreign-name (first spec) varp))) (string spec) - (symbol (let ((name (substitute #\_ #\- - (string-downcase (symbol-name spec))))) - (if varp - (string-trim '(#\*) name) - name))))) + (symbol (translate-name-to-foreign spec *package* varp)))) (defun foreign-options (spec varp) (let ((opts (if (listp spec) diff --git a/src/package.lisp b/src/package.lisp index 5153da0..e38ed79 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -71,6 +71,10 @@ #:defcfun #:foreign-funcall #:foreign-funcall-pointer + #:translate-camelcase-name + #:translate-name-from-foreign + #:translate-name-to-foreign + #:translate-underscore-separated-name ;; Foreign library operations. #:*foreign-library-directories* diff --git a/tests/defcfun.lisp b/tests/defcfun.lisp index 40e17f1..cae96a9 100644 --- a/tests/defcfun.lisp +++ b/tests/defcfun.lisp @@ -27,6 +27,52 @@ (in-package #:cffi-tests) +;;;# Name translation + +(deftest translate-underscore-separated-name.to-symbol + (translate-underscore-separated-name "some_name_with_underscores") + some-name-with-underscores) + +(deftest translate-underscore-separated-name.to-string + (translate-underscore-separated-name 'some-name-with-underscores) + "some_name_with_underscores") + +(deftest translate-camelcase-name.to-symbol + (translate-camelcase-name "someXmlFunction") + some-xml-function) + +(deftest translate-camelcase-name.to-string + (translate-camelcase-name 'some-xml-function) + "someXmlFunction") + +(deftest translate-camelcase-name.to-string-upper + (translate-camelcase-name 'some-xml-function :upper-initial-p t) + "SomeXmlFunction") + +(deftest translate-camelcase-name.to-symbol-special + (translate-camelcase-name "someXMLFunction" :special-words '("XML")) + some-xml-function) + +(deftest translate-camelcase-name.to-string-special + (translate-camelcase-name 'some-xml-function :special-words '("XML")) + "someXMLFunction") + +(deftest translate-name-from-foreign.function + (translate-name-from-foreign "some_xml_name" *package*) + some-xml-name) + +(deftest translate-name-from-foreign.var + (translate-name-from-foreign "some_xml_name" *package* t) + *some-xml-name*) + +(deftest translate-name-to-foreign.function + (translate-name-to-foreign 'some-xml-name *package*) + "some_xml_name") + +(deftest translate-name-to-foreign.var + (translate-name-to-foreign '*some-xml-name* *package* t) + "some_xml_name") + ;;;# Calling with built-in c types ;;; ;;; Tests calling standard C library functions both passing