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.31 2003/06/15 13:50:24 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   (or (uffi:null-pointer-p char-ptr)
  96       (char-equal #\N (uffi:ensure-char-character
  97                        (uffi:deref-pointer char-ptr :char)))))
  98
  99 (defun convert-raw-field (char-ptr types index)
 100   (declare (optimize (speed 3) (safety 0) (space 0)))
 101   (let ((type (if (listp types)
 102                   (nth index types)
 103                   types)))
 104     (cond
 105       ((and (or (eq type :double) (eq type :int32) (eq type :int)
 106                 (eq type :int64))
 107             (char-ptr-points-to-null char-ptr))
 108        nil)
 109       (t
 110        (case type
 111          (:double
 112           (atof char-ptr))
 113          ((or :int32 :int)
 114           (atoi char-ptr))
 115          (:int64
 116           (uffi:with-foreign-object (high32-ptr :int)
 117             (let ((low32 (atol64 char-ptr high32-ptr))
 118                   (high32 (uffi:deref-pointer high32-ptr :int)))
 119               (if (zerop high32)
 120                   low32
 121                   (make-64-bit-integer high32 low32)))))
 122          (t
 123           (uffi:convert-from-foreign-string char-ptr :locale :none)))))))
 124