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 ;;;; $Id: clsql-uffi.lisp,v 1.29 2003/06/06 21:59:09 kevin Exp $
  11 ;;;;
  12 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
  13 ;;;;
  14 ;;;; CLSQL users are granted the rights to distribute and use this software
  15 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  16 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  17 ;;;; *************************************************************************
  18
  19 (in-package #:clsql-uffi)
  20
  21
  22 (defun canonicalize-type-list (types auto-list)
  23   "Ensure a field type list meets expectations"
  24   (let ((length-types (length types))
  25         (new-types '()))
  26     (loop for i from 0 below (length auto-list)
  27           do
  28           (if (>= i length-types)
  29               (push t new-types) ;; types is shorted than num-fields
  30               (push
  31                (case (nth i types)
  32                  (:int
  33                   (case (nth i auto-list)
  34                     (:int32
  35                      :int32)
  36                     (:int64
  37                      :int64)
  38                     (t
  39                      t)))
  40                  (:double
  41                   (case (nth i auto-list)
  42                     (:double
  43                      :double)
  44                     (t
  45                      t)))
  46                  (:int32
  47                   (if (eq :int32 (nth i auto-list))
  48                       :int32
  49                     t))
  50                  (:int64
  51                   (if (eq :int64 (nth i auto-list))
  52                       :int64
  53                     t))
  54                  (t
  55                   t))
  56                new-types)))
  57     (nreverse new-types)))
  58
  59 (uffi:def-function "atoi"
  60     ((str (* :unsigned-char)))
  61   :returning :int)
  62
  63 (uffi:def-function "atol"
  64     ((str (* :unsigned-char)))
  65   :returning :long)
  66
  67 (uffi:def-function "atof"
  68     ((str (* :unsigned-char)))
  69   :returning :double)
  70
  71 (uffi:def-function "atol64"
  72     ((str (* :unsigned-char))
  73      (high32 (* :int)))
  74   :returning :unsigned-int)
  75
  76 (uffi:def-constant +2^32+ 4294967296)
  77 (uffi:def-constant +2^32-1+ (1- +2^32+))
  78
  79 (defmacro make-64-bit-integer (high32 low32)
  80   `(+ ,low32 (* ,high32 +2^32+)))
  81
  82 (defmacro split-64-bit-integer (int64)
  83   `(values (ash ,int64 -32) (logand ,int64 +2^32-1+)))
  84
  85 (uffi:def-type char-ptr-def (* :unsigned-char))
  86
  87 (defun char-ptr-points-to-null (char-ptr)
  88   "Returns T if foreign character pointer refers to 'NULL' string. Only called for numeric entries"
  89   ;; Uses short cut and returns T if first character is #\N. It should
  90   ;; never be non-numeric
  91   (declare (type char-ptr-def char-ptr))
  92   (char-equal #\N (uffi:ensure-char-character
  93                    (uffi:deref-pointer char-ptr :char))))
  94
  95 (defun convert-raw-field (char-ptr types index)
  96   (let ((type (if (listp types)
  97                   (nth index types)
  98                   types)))
  99     (cond
 100       ((and (or (eq type :double) (eq type :int32) (eq type :int)
 101                 (eq type :int64))
 102             (char-ptr-points-to-null char-ptr))
 103        nil)
 104       (t
 105        (case type
 106          (:double
 107           (atof char-ptr))
 108          ((or :int32 :int)
 109           (atoi char-ptr))
 110          (:int64
 111           (uffi:with-foreign-object (high32-ptr :int)
 112             (let ((low32 (atol64 char-ptr high32-ptr))
 113                   (high32 (uffi:deref-pointer high32-ptr :int)))
 114               (if (zerop high32)
 115                   low32
 116                   (make-64-bit-integer high32 low32)))))
 117          (t
 118           (uffi:convert-from-foreign-string char-ptr :locale :none)))))))
 119