[elephant-cvs] CVS elephant/src/memutil
ieslick
ieslick at common-lisp.net
Sun Feb 19 04:53:02 UTC 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 at common-lisp.net>
;;;
;;; part of
;;;
;;; Elephant: an object-oriented database for Common Lisp
;;;
;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee
;;; <ablumberg at common-lisp.net> <blee at 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 at common-lisp.net>
;;;
;;; part of
;;;
;;; Elephant: an object-oriented database for Common Lisp
;;;
;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee
;;; <ablumberg at common-lisp.net> <blee at 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 , at 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]
More information about the Elephant-cvs
mailing list