From 175fe97ee9ceefde40681fd1cddec73d815718b9 Mon Sep 17 00:00:00 2001
From: Dmitry Bogatov <KAction@gnu.org>
Date: Fri, 30 Jan 2015 08:23:48 +0300
Subject: [PATCH] Add string-like: ffi-object for more convenient alias syntax

  * lisp/gnu/bash.scm:

  * lisp/system/ffi.scm:

  * tests/alias.scm.in:
---
 lisp/gnu/bash.scm   |  8 ++++----
 lisp/system/ffi.scm | 22 ++++++++++++++++++++++
 tests/alias.scm.in  |  2 ++
 3 files changed, 28 insertions(+), 4 deletions(-)

diff --git a/lisp/gnu/bash.scm b/lisp/gnu/bash.scm
index 2beb663..33dd23a 100644
--- a/lisp/gnu/bash.scm
+++ b/lisp/gnu/bash.scm
@@ -100,17 +100,17 @@
   (map alias->pair (this-proc)))
 
 
-(define-ffi add-alias ((#:const string: name) (#:const string: value) -> void:))
-(define-ffi get-alias-value ((#:const string: name) -> ?string:))
+(define-ffi add-alias ((#:const string-like: name) (#:const string-like: value) -> void:))
+(define-ffi get-alias-value ((#:const string-like: name) -> ?string:))
 (export add-alias get-alias-value)
 
-(define-ffi remove-alias ((#:const string: name) -> int:))
+(define-ffi remove-alias ((#:const string-like: name) -> int:))
 (define-override (remove-alias name)
   (let ((successfully-removed? (not {(this-proc name) = -1})))
     successfully-removed?))
 
 (define-ffi delete-all-aliases (-> void:))
-(define-ffi alias-expand ((#:const string: name) -> #:alloc string:))
+(define-ffi alias-expand ((#:const string-like: name) -> #:alloc string:))
 (export alias-expand delete-all-aliases)
 
 (define-extern (int: last-command-exit-value))
diff --git a/lisp/system/ffi.scm b/lisp/system/ffi.scm
index 431ab2a..dbc0cc2 100644
--- a/lisp/system/ffi.scm
+++ b/lisp/system/ffi.scm
@@ -557,6 +557,28 @@
   #:clone c-strdup
   #:free c-free)
 
+(define (string-like->pointer obj)
+  (string->pointer
+   (let loop ((object obj))
+     (let/ec return
+       (when (string? object)
+	 (return object))
+       (when (symbol? object)
+	 (return (loop (symbol->string object))))
+       (when (keyword? object)
+	 (return (loop (keyword->symbol object))))
+       (scm-error 'wrong-type-arg "string-like->pointer"
+		  "Unsupported value ~A" (list obj))))))
+
+(define (pointer->string-like ptr)
+  (string->symbol (pointer->string ptr)))
+
+(export string-like:)
+(define-ffi-object string-like:
+  #:decoder pointer->string-like
+  #:encoder string-like->pointer
+  #:clone c-strdup
+  #:free c-free)
 
 (define (toplevel-define-scm-struct-class struct-name field-names)
   (define class-name (symbol-append '<struct- struct-name '>))
diff --git a/tests/alias.scm.in b/tests/alias.scm.in
index d3032b6..90b8747 100644
--- a/tests/alias.scm.in
+++ b/tests/alias.scm.in
@@ -13,5 +13,7 @@
  (test-equal 4 (length (all-aliases)))
  (delete-all-aliases)
  (test-equal '() (all-aliases))
+ (add-alias #:some-alias #:some-value)
+ (test-equal "some-value" (get-alias-value 'some-alias))
  (delete-all-aliases)
  (add-alias "the-alias" "some expansion"))
-- 
2.11.4.GIT