gnunet/gnu/gnunet/binding-utils.scm

;;;; -*- mode: Scheme; indent-tabs-mode: nil; fill-column: 80; -*-
;;;; 
;;;; Copyright © 2015 Rémi Delrue <asgeir@free.fr>
;;;; 
;;;; This program is free software: you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation, either version 3 of the License, or
;;;; (at your option) any later version.
;;;; 
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gnu gnunet binding-utils)
  #:use-module (ice-9 match)
  #:use-module ((srfi srfi-1) #:select (find))
  #:use-module (rnrs bytevectors)
  #:use-module (system foreign)
  #:export (getf
            interleave
            
            rassq
            rassq-ref
            rassv
            rassv-ref
            rassoc
            rassoc-ref

            destructuring-bind
            
            string->pointer*
            pointer->string*
            make-c-struct*
            or%
            and=>%))

(define (getf plist value)
  (let ((entry (member value plist)))
    (if entry (cadr entry) #f)))

;; reverse association lists
(define-syntax-rule (define-assoc name name-ref test)
  (begin
    (define (name alist value)
      "Return the first entry in ALIST with the given VALUE."
      (find (match-lambda ((_ . val) (test value val))) alist))

    (define (name-ref alist value)
      "Return the key from the first entry in ALIST with the given VALUE."
      (car (or (name alist value) '(#f . #f))))))

(define-assoc rassq  rassq-ref  eq?)
(define-assoc rassv  rassv-ref  eqv?)
(define-assoc rassoc rassoc-ref equal?)

(define (interleave obj lst)
  "Interleaves OBJ in LST.

	(interleave '& '(kirk spock ahura sulu scotty))
	⇒
	(kirk & spock & ahura & sulu & scotty)"
  (define (%interleave lst)
    (if (null? lst)
        lst
        (cons obj (cons (car lst) (%interleave (cdr lst))))))
  (if (or (null? lst) (null? (cdr lst)))
      lst
      (cons (car lst) (%interleave (cdr lst)))))


;;; FFI utilities

(define (string->pointer* string)
  "Return a foreign pointer to a nul-terminated copy of STRING, or %null-pointer
if STRING is empty (\"\")."
  (if (string=? "" string) %null-pointer (string->pointer string)))

(define (pointer->string* ptr)
  (if (eq? %null-pointer ptr) #f (pointer->string ptr)))

;; a variant of OR for foreign pointers.
;; ex:                       (or% 'a 'b) → A
;;                (or% %null-pointer 'b) → B
;;     (or% %null-pointer %null-pointer) → #f
(define-syntax or%
  (syntax-rules ()
    ((_ x)       (let ((x* x))
                   (if (eq? %null-pointer x*)
                       #f
                       x*)))
    ((_ x y ...) (let ((x* x))
                   (if (eq? %null-pointer x*)
                       (or% y ...)
                       x*)))))

;; a variant of and=> for foreign pointers.
(define-syntax-rule (and=>% x f)
  (let ((x* x))
    (if (eq? %null-pointer x*)
        #f
        (f x*))))

;;; Utilities

(define-syntax-rule (destructuring-bind pattern value body body* ...)
  (match value (pattern body body* ...)))