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 #-windows
  75 (uffi:def-function ("strtoull" c-strtoull)
  76     ((str (* :unsigned-char))
  77      (endptr (* :unsigned-char))
  78      (radix :int))
  79   :returning :unsigned-long-long)
  80
  81 #+windows
  82 (uffi:def-function ("_strtoui64" c-strtoull)
  83     ((str (* :unsigned-char))
  84      (endptr (* :unsigned-char))
  85      (radix :int))
  86   :returning :unsigned-long-long)
  87
  88 (uffi:def-function "atol"
  89     ((str (* :unsigned-char)))
  90   :returning :long)
  91
  92 (uffi:def-function "atof"
  93     ((str (* :unsigned-char)))
  94   :returning :double)
  95
  96 (uffi:def-function "atol64"
  97     ((str (* :unsigned-char))
  98      (high32 (* :unsigned-int)))
  99   :module "clsql-uffi"
 100   :returning :unsigned-int)
 101
 102 (uffi:def-constant +2^32+ 4294967296)
 103 (uffi:def-constant +2^64+ 18446744073709551616)
 104 (uffi:def-constant +2^32-1+ (1- +2^32+))
 105
 106 (defmacro make-64-bit-integer (high32 low32)
 107   `(if (zerop (ldb (byte 1 31) ,high32))
 108        (+ ,low32 (ash ,high32 32))
 109      (- (+ ,low32 (ash ,high32 32)) +2^64+)))
 110
 111 ;; From high to low ints
 112 (defmacro make-128-bit-integer (a b c d)
 113   `(+ ,d (ash ,c 32) (ash ,b 64) (ash ,a 96)))
 114
 115 (defmacro split-64-bit-integer (int64)
 116   `(values (ash ,int64 -32) (logand ,int64 +2^32-1+)))
 117
 118 (uffi:def-type char-ptr-def (* :unsigned-char))
 119
 120 (defun strtoul (char-ptr)
 121   (declare (optimize (speed 3) (safety 0) (space 0))
 122            (type char-ptr-def char-ptr))
 123   (c-strtoul char-ptr uffi:+null-cstring-pointer+ 10))
 124
 125 (defun strtoull (char-ptr)
 126   (declare (optimize (speed 3) (safety 0) (space 0))
 127            (type char-ptr-def char-ptr))
 128   (c-strtoull char-ptr uffi:+null-cstring-pointer+ 10))
 129
 130 (defun convert-raw-field (char-ptr type &key length encoding)
 131  (declare (optimize (speed 3) (safety 0) (space 0))
 132           (type char-ptr-def char-ptr))
 133  (cond
 134    ((uffi:null-pointer-p char-ptr)
 135     nil)
 136    (t
 137     (case type
 138       (:double
 139        (atof char-ptr))
 140       (:int
 141        (atol char-ptr))
 142       (:int32
 143        (atoi char-ptr))
 144       (:uint32
 145        (strtoul char-ptr))
 146       (:uint
 147        (strtoul char-ptr))
 148       ((:int64 :uint64)
 149        (strtoull char-ptr)
 150        #|(uffi:with-foreign-object (high32-ptr :unsigned-int)
 151          (let ((low32 (atol64 char-ptr high32-ptr))
 152                (high32 (uffi:deref-pointer high32-ptr :unsigned-int)))
 153            (if (zerop high32)
 154                low32
 155                (make-64-bit-integer high32 low32))))|#
 156 )
 157       (:blob
 158        (if length
 159            (uffi:convert-from-foreign-usb8 char-ptr length)
 160            (error "Can't return blob since length is not specified.")))
 161       (t
 162        (if encoding
 163            (if length
 164                (uffi:convert-from-foreign-string char-ptr
 165                                                  :null-terminated-p nil
 166                                                  :length length
 167                                                  :encoding encoding)
 168                (uffi:convert-from-foreign-string char-ptr
 169                                                  :null-terminated-p t
 170                                                  :encoding encoding))
 171            (if length
 172                (uffi:convert-from-foreign-string char-ptr
 173                                                  :null-terminated-p nil
 174                                                  :length length)
 175                (uffi:convert-from-foreign-string char-ptr
 176                                                  :null-terminated-p t))))))))