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