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.30 2003/06/08 12:48:55 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   (declaim (optimize (speed 3) (safety 0)))
  25   (do ((i 0 (1+ i))
  26        (new-types '())
  27        (length-types (length types))
  28        (length-auto-list (length auto-list)))
  29       ((= i length-auto-list)
  30        (nreverse new-types))
  31     (declaim (fixnum length-types length-auto-list i))
  32     (if (>= i length-types)
  33         (push t new-types) ;; types is shorted than num-fields
  34         (push
  35          (case (nth i types)
  36            (:int
  37             (case (nth i auto-list)
  38               (:int32
  39                :int32)
  40               (:int64
  41                :int64)
  42               (t
  43                t)))
  44            (:double
  45             (case (nth i auto-list)
  46               (:double
  47                :double)
  48               (t
  49                t)))
  50            (:int32
  51             (if (eq :int32 (nth i auto-list))
  52                 :int32
  53                 t))
  54            (:int64
  55             (if (eq :int64 (nth i auto-list))
  56                 :int64
  57                 t))
  58            (t
  59             t))
  60          new-types))))
  61
  62 (uffi:def-function "atoi"
  63     ((str (* :unsigned-char)))
  64   :returning :int)
  65
  66 (uffi:def-function "atol"
  67     ((str (* :unsigned-char)))
  68   :returning :long)
  69
  70 (uffi:def-function "atof"
  71     ((str (* :unsigned-char)))
  72   :returning :double)
  73
  74 (uffi:def-function "atol64"
  75     ((str (* :unsigned-char))
  76      (high32 (* :int)))
  77   :returning :unsigned-int)
  78
  79 (uffi:def-constant +2^32+ 4294967296)
  80 (uffi:def-constant +2^32-1+ (1- +2^32+))
  81
  82 (defmacro make-64-bit-integer (high32 low32)
  83   `(+ ,low32 (ash ,high32 32)))
  84
  85 (defmacro split-64-bit-integer (int64)
  86   `(values (ash ,int64 -32) (logand ,int64 +2^32-1+)))
  87
  88 (uffi:def-type char-ptr-def (* :unsigned-char))
  89
  90 (defun char-ptr-points-to-null (char-ptr)
  91   "Returns T if foreign character pointer refers to 'NULL' string. Only called for numeric entries"
  92   ;; Uses short cut and returns T if first character is #\N. It should
  93   ;; never be non-numeric
  94   (declare (type char-ptr-def char-ptr))
  95   (char-equal #\N (uffi:ensure-char-character
  96                    (uffi:deref-pointer char-ptr :char))))
  97
  98 (defun convert-raw-field (char-ptr types index)
  99   (declare (optimize (speed 3) (safety 0) (space 0)))
 100   (let ((type (if (listp types)
 101                   (nth index types)
 102                   types)))
 103     (cond
 104       ((and (or (eq type :double) (eq type :int32) (eq type :int)
 105                 (eq type :int64))
 106             (char-ptr-points-to-null char-ptr))
 107        nil)
 108       (t
 109        (case type
 110          (:double
 111           (atof char-ptr))
 112          ((or :int32 :int)
 113           (atoi char-ptr))
 114          (:int64
 115           (uffi:with-foreign-object (high32-ptr :int)
 116             (let ((low32 (atol64 char-ptr high32-ptr))
 117                   (high32 (uffi:deref-pointer high32-ptr :int)))
 118               (if (zerop high32)
 119                   low32
 120                   (make-64-bit-integer high32 low32)))))
 121          (t
 122           (uffi:convert-from-foreign-string char-ptr :locale :none)))))))
 123