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.28 2003/05/29 05:19:50 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 (defvar +ascii-N-value+ (char-code #\N))
  86 (defvar +ascii-U-value+ (char-code #\U))
  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   (let ((char (uffi:ensure-char-character
  96                (uffi:deref-pointer char-ptr :char))))
  97     (char-equal char #\N)))
  98
  99 (defun convert-raw-field (char-ptr types index)
 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           #+(or allegro lispworks) (native-to-string char-ptr) ;; optimized
 123           #-(or allegro lispworks) (uffi:convert-from-foreign-string char-ptr)))))))
 124
 125
 126 (uffi:def-function "strlen"
 127     ((str (* :unsigned-char)))
 128   :returning :unsigned-int)
 129
 130 #+(or lispworks (and allegro ics))
 131 (defun native-to-string (s)
 132   (declare (optimize (speed 3) (space 0) (safety 0) (compilation-speed 0))
 133            (type char-ptr-def s))
 134   (let* ((len (strlen s))
 135          (str (make-string len)))
 136     (declare (fixnum len)
 137              (simple-string str))
 138     (do ((i 0))
 139         ((= i len))
 140       (declare (fixnum i))
 141       (setf (schar str i)
 142         (code-char (uffi:deref-array s '(:array :unsigned-char) i)))
 143       (incf i))
 144     str))
 145
 146 #+(and allegro (not ics))
 147 (defun native-to-string (s)
 148   (declare (optimize (speed 3) (space 0) (safety 0) (compilation-speed 0))
 149            (type char-ptr-def s))
 150   (let* ((len (strlen s))
 151          (len4 (floor len 4))
 152          (str (make-string len)))
 153     (declare (fixnum len)
 154              (type (simple-array (signed-byte 32) (*)) str))
 155     (do ((i 0))
 156         ((= i len4))
 157       (declare (fixnum i))
 158       (setf (aref (the (simple-array (signed-byte 32) (*)) str) i)
 159         (uffi:deref-array s '(:array :int) i))
 160         (incf i))
 161     (do ((i (* 4 len4)))
 162         ((= i len))
 163       (declare (fixnum i))
 164       (setf (aref (the (simple-array (signed-byte 8) (*)) str) i)
 165         (uffi:deref-array s '(:array :unsigned-char) i))
 166       (incf i))
 167     str))