[elephant-cvs] CVS elephant/src/memutil - elephant-cvs@common-lisp.net - mailman3.common-lisp.net

19 Feb 2006


      Update of /project/elephant/cvsroot/elephant/src/memutil
In directory common-lisp:/tmp/cvs-serv7130/src/memutil
Added Files:
    libmemutil.c memutil.lisp 
Log Message:
See elephant-devel mail for changes...and take a big, deep breath...
--- /project/elephant/cvsroot/elephant/src/memutil/libmemutil.c	2006/02/19 04:53:02	NONE
+++ /project/elephant/cvsroot/elephant/src/memutil/libmemutil.c	2006/02/19 04:53:02	1.1
/*
;;;
;;; libsleepycat.c -- C wrappers for Sleepycat for FFI
;;; 
;;; Initial version 8/26/2004 by Ben Lee
;;; blee@common-lisp.net
;;; 
;;; part of
;;;
;;; Elephant: an object-oriented database for Common Lisp
;;;
;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee
;;; ablumberg@common-lisp.net blee@common-lisp.net
;;;
;;; This program is released under the following license
;;; ("GPL").  For differenct licensing terms, contact the
;;; copyright holders.
;;;
;;; This program is free software; you can redistribute it
;;; and/or modify it under the terms of the GNU General
;;; Public License as published by the Free Software
;;; Foundation; either version 2 of the License, or (at
;;; your option) any later version.
;;;
;;; This program is distributed in the hope that it will be
;;; useful, but WITHOUT ANY WARRANTY; without even the
;;; implied warranty of MERCHANTABILITY or FITNESS FOR A
;;; PARTICULAR PURPOSE. See the GNU General Public License
;;; for more details.
;;;
;;; The GNU General Public License can be found in the file
;;; LICENSE which should have been distributed with this
;;; code.  It can also be found at
;;;
;;; http://www.opensource.org/licenses/gpl-license.php
;;;
;;; You should have received a copy of the GNU General
;;; Public License along with this program; if not, write
;;; to the Free Software Foundation, Inc., 59 Temple Place,
;;; Suite 330, Boston, MA 02111-1307 USA
;;;
;;; Portions of this program (namely the C unicode string
;;; sorter) are derived from IBM's ICU:
;;;
;;; http://oss.software.ibm.com/icu/
;;;
;;; Copyright (c) 1995-2003 International Business Machines
;;; Corporation and others All rights reserved.
;;;
;;; ICU's copyright, license and warranty can be found at
;;;
;;; http://oss.software.ibm.com/cvs/icu/~checkout~/icu/license.html
;;;
;;; or in the file LICENSE.
;;;
*/
#include <string.h>
#include <wchar.h>
/* Pointer arithmetic utility functions */
/* should these be in network-byte order? probably not..... */
int read_int(char *buf, int offset) {
  int i;
  memcpy(&i, buf+offset, sizeof(int));
  return i;
}
unsigned int read_uint(char *buf, int offset) {
  unsigned int ui; 
  memcpy(&ui, buf+offset, sizeof(unsigned int));
  return ui;
}
float read_float(char *buf, int offset) {
  float f;
  memcpy(&f, buf+offset, sizeof(float));
  return f;
}
double read_double(char *buf, int offset) {
  double d;
  memcpy(&d, buf+offset, sizeof(double));
  return d;
}
void write_int(char *buf, int num, int offset) {
  memcpy(buf+offset, &num, sizeof(int));
}
void write_uint(char *buf, unsigned int num, int offset) {
  memcpy(buf+offset, &num, sizeof(unsigned int));
}
void write_float(char *buf, float num, int offset) {
  memcpy(buf+offset, &num, sizeof(float));
}
void write_double(char *buf, double num, int offset) {
  memcpy(buf+offset, &num, sizeof(double));
}
char *offset_charp(char *p, int offset) {
  return p + offset;
}
void copy_buf(char *dest, int dest_offset, char *src, int src_offset, 
          int length) {
  memcpy(dest + dest_offset, src + src_offset, length);
}
--- /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp	2006/02/19 04:53:02	NONE
+++ /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp	2006/02/19 04:53:02	1.1
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;
;;; memutil.lisp -- FFI interface to UFFI/memory as base for serializer.lisp
;;; 
;;; Initial version 8/26/2004 by Ben Lee
;;; blee@common-lisp.net
;;; 
;;; part of
;;;
;;; Elephant: an object-oriented database for Common Lisp
;;;
;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee
;;; ablumberg@common-lisp.net blee@common-lisp.net
;;;
;;; Elephant users are granted the rights to distribute and use this software
;;; as governed by the terms of the Lisp Lesser GNU Public License
;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;
(defpackage elephant-memutil
  (:documentation "A low-level UFFI-based memory access and
    serialization toolkit.  Provides basic cross-platform
    binary serialization support for backends.")
  (:use common-lisp uffi)
  #+cmu
  (:use alien)
  #+sbcl
  (:use sb-alien)
  #+cmu
  (:import-from :sys
    	#:sap+)
  #+sbcl
  (:import-from :sb-sys
    	#:sap+)  
  #+openmcl
  (:import-from :ccl
    	#:byte-length)
  (:export    
       #:buffer-stream #:make-buffer-stream #:with-buffer-streams
       #:resize-buffer-stream #:resize-buffer-stream-no-copy 
       #:reset-buffer-stream #:buffer-stream-buffer 
       #:buffer-stream-length #:buffer-stream-size
       #:buffer-write-byte #:buffer-write-int
       #:buffer-write-uint #:buffer-write-float #:buffer-write-double 
       #:buffer-write-string #:buffer-read-byte #:buffer-read-fixnum 
       #:buffer-read-int #:buffer-read-uint #:buffer-read-float 
       #:buffer-read-double 
       #:buffer-read-ucs1-string
       #+(or lispworks (and allegro ics)) #:buffer-read-ucs2-string 
       #+(and sbcl sb-unicode) #:buffer-read-ucs4-string 
       #:byte-length
       
       #:pointer-int #:pointer-void #:array-or-pointer-char
       +NULL-CHAR+ +NULL-VOID+
       ))
(in-package "ELEPHANT-MEMUTIL")
#+cmu
(eval-when (:compile-toplevel)
  (proclaim '(optimize (ext:inhibit-warnings 3))))
(eval-when (:compile-toplevel :load-toplevel)
  (defparameter *c-library-extension*
    #+(or darwin macosx) "dylib"
    #-(or darwin macosx) "so" )
(defvar *elephant-lib-path* "/usr/local/share/common-lisp/elephant/"))
(eval-when (:compile-toplevel :load-toplevel)
(unless
        (uffi:load-foreign-library 
         (if (find-package 'asdf)
       (merge-pathnames 
        (make-pathname :name "libmemutil" :type *c-library-extension*)
        (asdf:component-pathname (asdf:find-system 'elephant)))
       (format nil "~A/~A.~A" *elephant-lib-path* "libmemutil" *c-library-extension*))
         :module "libmemutil")
      (error "Couldn't load libmemutil.~A!" *c-library-extension*))
;; fini on user editable part
(def-type pointer-int (* :int))
  (def-type pointer-void :pointer-void)
  (def-foreign-type array-or-pointer-char
      #+allegro (:array :char)
      #+(or cmu sbcl scl openmcl) (* :char))
  (def-type array-or-pointer-char array-or-pointer-char)
  )
(declaim (inline read-int read-uint read-float read-double 
    	 write-int write-uint write-float write-double
    	 offset-char-pointer copy-str-to-buf %copy-str-to-buf copy-bufs
    	 ;;resize-buffer-stream 
    	 ;;buffer-stream-buffer buffer-stream-size buffer-stream-position
    	 ;;buffer-stream-length 
    	 reset-buffer-stream
    	 buffer-write-byte buffer-write-int buffer-write-uint
    	 buffer-write-float buffer-write-double buffer-write-string
    	 buffer-read-byte buffer-read-fixnum buffer-read-int
    	 buffer-read-uint buffer-read-float buffer-read-double 
    	 buffer-read-ucs1-string
    	 #+(or lispworks (and allegro ics)) buffer-read-ucs2-string
    	 #+(and sbcl sb-unicode) buffer-read-ucs4-string))
;; Constants and Flags
;; eventually write a macro which generates a custom flag function.
(defvar +NULL-VOID+ (make-null-pointer :void)
  "A null pointer to a void type.")
(defvar +NULL-CHAR+ (make-null-pointer :char)
  "A null pointer to a char type.")
;; Thread local storage (special variables)
(defvar *buffer-streams* (make-array 0 :adjustable t :fill-pointer t)
  "Vector of buffer-streams, which you can grab / return.")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; buffer-streams
;;;
;;; a stream-like interface for our buffers; methods are
;;; below.  ultimately we might want a gray / simple -stream
;;; for real, for now who cares?
(defstruct buffer-stream
  "A stream-like interface to foreign (alien) char buffers."
  (buffer (allocate-foreign-object :char 10) :type array-or-pointer-char)
  (size 0 :type fixnum)
  (position 0 :type fixnum)
  (length 10 :type fixnum))
(defun grab-buffer-stream ()
  "Grab a buffer-stream from the *buffer-streams* resource pool."
  (declare (optimize (speed 3)))
  (if (= (length *buffer-streams*) 0)
      (make-buffer-stream)
      (vector-pop *buffer-streams*)))
(defun return-buffer-stream (bs)
  "Return a buffer-stream to the *buffer-streams* resource pool."
  (declare (optimize (speed 3)))
  (reset-buffer-stream bs)
  (vector-push-extend bs *buffer-streams*))
(defmacro with-buffer-streams (names &body body)
  "Grab a buffer-stream, executes forms, and returns the
stream to the pool on exit."
  `(let ,(loop for name in names collect (list name '(grab-buffer-stream)))
    (unwind-protect
     (progn ,@body)
      (progn
    ,@(loop for name in names 
    	collect (list 'return-buffer-stream name))))))
;; Buffer management / pointer arithmetic
;; Notes: on Allegro: with-cast-pointer + deref-array is
;; faster than FFI + C pointer arithmetic.  however pointer
;; arithmetic is usually consing.  OpenMCL supports
;; non-consing pointer arithmentic though.  Check these
;; CMUCL / SBCL things don't cons unless necessary.
;; TODO: #+openmcl versions which do macptr arith.
#+(or cmu sbcl)
(defun read-int (buf offset)
  "Read a 32-bit signed integer from a foreign char buffer."
  (declare (optimize (speed 3) (safety 0))
       (type (alien (* char)) buf)
       (type fixnum offset))
  (the (signed-byte 32)
    (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char))
    	 (* integer)))))
#+(or cmu sbcl)
(defun read-uint (buf offset)
  "Read a 32-bit unsigned integer from a foreign char buffer."
  (declare (optimize (speed 3) (safety 0))
       (type (alien (* char)) buf)
       (type fixnum offset))
  (the (unsigned-byte 32)
    (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char))
    	 (* (unsigned 32))))))
#+(or cmu sbcl)
(defun read-float (buf offset)
  "Read a single-float from a foreign char buffer."
  (declare (optimize (speed 3) (safety 0))
       (type (alien (* char)) buf)
       (type fixnum offset))
  (the single-float
    (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char))
    	 (* single-float)))))
#+(or cmu sbcl)
(defun read-double (buf offset)
  "Read a double-float from a foreign char buffer."
  (declare (optimize (speed 3) (safety 0))
       (type (alien (* char)) buf)
       (type fixnum offset))
  (the double-float
    (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char))
    	 (* double-float)))))
#+(or cmu sbcl)
(defun write-int (buf num offset)
  "Write a 32-bit signed integer to a foreign char buffer."
  (declare (optimize (speed 3) (safety 0))
       (type (alien (* char)) buf)
       (type (signed-byte 32) num)
       (type fixnum offset))
  (setf (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char))
    	     (* integer))) num))
#+(or cmu sbcl)
(defun write-uint (buf num offset)
  "Write a 32-bit unsigned integer to a foreign char buffer."
  (declare (optimize (speed 3) (safety 0))
       (type (alien (* char)) buf)
       (type (unsigned-byte 32) num)
       (type fixnum offset))
  (setf (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char))
    	     (* (unsigned 32)))) num))
#+(or cmu sbcl)
(defun write-float (buf num offset)
  "Write a single-float to a foreign char buffer."
  (declare (optimize (speed 3) (safety 0))
       (type (alien (* char)) buf)
       (type single-float num)
       (type fixnum offset))
  (setf (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char))
    	     (* single-float))) num))
#+(or cmu sbcl)
(defun write-double (buf num offset)
  "Write a double-float to a foreign char buffer."
  (declare (optimize (speed 3) (safety 0))
       (type (alien (* char)) buf)
       (type double-float num)
       (type fixnum offset))
  (setf (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char))
    	     (* double-float))) num))
#+(or cmu sbcl)
(defun offset-char-pointer (p offset)
  "Pointer arithmetic."
  (declare (optimize (speed 3) (safety 0))
       (type (alien (* char)) p)
       (type fixnum offset))
  (sap-alien (sap+ (alien-sap p) offset) (* char)))
#-(or cmu sbcl)
(def-function ("read_int" read-int)
    ((buf array-or-pointer-char)
     (offset :int))
  :returning :int)
#-(or cmu sbcl)
(def-function ("read_uint" read-uint)
    ((buf array-or-pointer-char)
     (offset :int))
  :returning :unsigned-int)
#-(or cmu sbcl)
(def-function ("read_float" read-float)
    ((buf array-or-pointer-char)
     (offset :int))
  :returning :float)
#-(or cmu sbcl)
(def-function ("read_double" read-double)
    ((buf array-or-pointer-char)
     (offset :int))
  :returning :double)
#-(or cmu sbcl)
(def-function ("write_int" write-int)
    ((buf array-or-pointer-char)
     (num :int)
     (offset :int))
  :returning :void)
#-(or cmu sbcl)
(def-function ("write_uint" write-uint)
    ((buf array-or-pointer-char)
[454 lines skipped]