uffi/clsql-uffi.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          clsql-uffi.cl
   6 ;;;; Purpose:       Common functions for interfaces using UFFI
   7 ;;;; Programmers:   Kevin M. Rosenberg
   8 ;;;; Date Started:  Mar 2002
   9 ;;;;
  10 ;;;; This file, part of CLSQL, is Copyright (c) 2002-2010 by Kevin M. Rosenberg
  11 ;;;;
  12 ;;;; CLSQL users are granted the rights to distribute and use this software
  13 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  14 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  15 ;;;; *************************************************************************
  16
  17 (in-package #:clsql-uffi)
  18
  19
  20 (defun canonicalize-type-list (types auto-list)
  21   "Ensure a field type list meets expectations"
  22   (declare (optimize (speed 3) (safety 0)))
  23   (do ((i 0 (1+ i))
  24        (new-types '())
  25        (length-types (length types))
  26        (length-auto-list (length auto-list)))
  27       ((= i length-auto-list)
  28        (nreverse new-types))
  29     (declare (fixnum length-types length-auto-list i))
  30     (if (>= i length-types)
  31         (push t new-types) ;; types is shorter than num-fields
  32         (push
  33          (case (nth i types)
  34            (:int
  35             (case (nth i auto-list)
  36               (:int32
  37                :int32)
  38               (:int64
  39                :int64)
  40               (t
  41                t)))
  42            (:double
  43             (case (nth i auto-list)
  44               (:double
  45                :double)
  46               (t
  47                t)))
  48            (:int32
  49             (if (eq :int32 (nth i auto-list))
  50                 :int32
  51                 t))
  52            (:int64
  53             (if (eq :int64 (nth i auto-list))
  54                 :int64
  55               t))
  56            (:blob
  57             :blob)
  58            (:uint
  59             :uint)
  60            (t
  61             t))
  62          new-types))))
  63
  64 (uffi:def-function "atoi"
  65     ((str (* :unsigned-char)))
  66   :returning :int)
  67
  68 (uffi:def-function ("strtoul" c-strtoul)
  69     ((str (* :unsigned-char))
  70      (endptr (* :unsigned-char))
  71      (radix :int))
  72   :returning :unsigned-long)
  73
  74 (uffi:def-function "atol"
  75     ((str (* :unsigned-char)))
  76   :returning :long)
  77
  78 (uffi:def-function "atof"
  79     ((str (* :unsigned-char)))
  80   :returning :double)
  81
  82 (uffi:def-function "atol64"
  83     ((str (* :unsigned-char))
  84      (high32 (* :unsigned-int)))
  85   :module "clsql-uffi"
  86   :returning :unsigned-int)
  87
  88 (uffi:def-constant +2^32+ 4294967296)
  89 (uffi:def-constant +2^64+ 18446744073709551616)
  90 (uffi:def-constant +2^32-1+ (1- +2^32+))
  91
  92 (defmacro make-64-bit-integer (high32 low32)
  93   `(if (zerop (ldb (byte 1 31) ,high32))
  94        (+ ,low32 (ash ,high32 32))
  95      (- (+ ,low32 (ash ,high32 32)) +2^64+)))
  96
  97 ;; From high to low ints
  98 (defmacro make-128-bit-integer (a b c d)
  99   `(+ ,d (ash ,c 32) (ash ,b 64) (ash ,a 96)))
 100
 101 (defmacro split-64-bit-integer (int64)
 102   `(values (ash ,int64 -32) (logand ,int64 +2^32-1+)))
 103
 104 (uffi:def-type char-ptr-def (* :unsigned-char))
 105
 106 (defun strtoul (char-ptr)
 107   (declare (optimize (speed 3) (safety 0) (space 0))
 108            (type char-ptr-def char-ptr))
 109   (c-strtoul char-ptr uffi:+null-cstring-pointer+ 10))
 110
 111 (defun convert-raw-field (char-ptr type &key length encoding)
 112  (declare (optimize (speed 3) (safety 0) (space 0))
 113           (type char-ptr-def char-ptr))
 114  (cond
 115    ((uffi:null-pointer-p char-ptr)
 116     nil)
 117    (t
 118     (case type
 119       (:double
 120        (atof char-ptr))
 121       (:int
 122        (atol char-ptr))
 123       (:int32
 124        (atoi char-ptr))
 125       (:uint32
 126        (strtoul char-ptr))
 127       (:uint
 128        (strtoul char-ptr))
 129       ((:int64 :uint64)
 130        (uffi:with-foreign-object (high32-ptr :unsigned-int)
 131          (let ((low32 (atol64 char-ptr high32-ptr))
 132                (high32 (uffi:deref-pointer high32-ptr :unsigned-int)))
 133            (if (zerop high32)
 134                low32
 135                (make-64-bit-integer high32 low32)))))
 136       (:blob
 137        (if length
 138            (uffi:convert-from-foreign-usb8 char-ptr length)
 139            (error "Can't return blob since length is not specified.")))
 140       (t
 141        (if encoding
 142            (if length
 143                (uffi:convert-from-foreign-string char-ptr
 144                                                  :null-terminated-p nil
 145                                                  :length length
 146                                                  :encoding encoding)
 147                (uffi:convert-from-foreign-string char-ptr
 148                                                  :null-terminated-p t
 149                                                  :encoding encoding))
 150            (if length
 151                (uffi:convert-from-foreign-string char-ptr
 152                                                  :null-terminated-p nil
 153                                                  :length length)
 154                (uffi:convert-from-foreign-string char-ptr
 155                                                  :null-terminated-p t))))))))