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