March 2007 - elephant-cvs@common-lisp.net

[elephant-cvs] CVS elephant/src/db-bdb
by ieslick 04 Mar '07

04 Mar '07

Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory clnet:/tmp/cvs-serv26542 Modified Files: bdb-transactions.lisp Log Message: Fixed bdb execute transations to properly return multiple values --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-transactions.lisp 2007/02/20 19:12:58 1.10 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-transactions.lisp 2007/03/04 20:22:47 1.11 @@ -40,21 +40,22 @@ :txn-sync txn-sync)))) (declare (type pointer-void txn)) (let ((result - (let ((*current-transaction* (make-transaction-record sc txn)) - (*store-controller* sc)) - (declare (special *current-transaction* *store-controller*)) - (catch 'transaction - (unwind-protect - (multiple-value-prog1 - (funcall txn-fn) - (db-transaction-commit txn - :txn-nosync txn-nosync - :txn-sync txn-sync) - (setq success t)) - (unless success - (db-transaction-abort txn))))))) + (multiple-value-list + (let ((*current-transaction* (make-transaction-record sc txn)) + (*store-controller* sc)) + (declare (special *current-transaction* *store-controller*)) + (catch 'transaction + (unwind-protect + (multiple-value-prog1 + (funcall txn-fn) + (db-transaction-commit txn + :txn-nosync txn-nosync + :txn-sync txn-sync) + (setq success t)) + (unless success + (db-transaction-abort txn)))))))) (unless (and (eq result txn) (not success)) - (return result)))) + (return (values-list result))))) finally (error "Too many retries in transaction")))) (defmethod controller-start-transaction ((sc bdb-store-controller)

1 0

[elephant-cvs] CVS elephant/tests
by ieslick 03 Mar '07

03 Mar '07

Update of /project/elephant/cvsroot/elephant/tests In directory clnet:/tmp/cvs-serv18095/tests Modified Files: testindexing.lisp Log Message: Fixes for Win32 allegro build; lispwork builds but fails to run; new test of :index class keyword which fails --- /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2007/02/26 19:55:13 1.31 +++ /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2007/03/03 17:25:01 1.32 @@ -102,6 +102,20 @@ )) 3 2 1 t 3) +(deftest indexing-class-opt + (progn + (when (class-indexedp-by-name 'idx-cslot) + (disable-class-indexing 'idx-cslot :errorp nil) + (setf (find-class 'idx-cslot) nil)) + + (defclass idx-cslot () + ((slot1 :initarg :slot1 :initform 0 :accessor slot1)) + (:metaclass persistent-metaclass :index t)) + + (values (class-indexedp-by-name 'idx-cslot))) + t) + + ;; test inherited slots (deftest indexing-inherit (progn

1 0

[elephant-cvs] CVS elephant/src/memutil
by ieslick 03 Mar '07

03 Mar '07

Update of /project/elephant/cvsroot/elephant/src/memutil In directory clnet:/tmp/cvs-serv18095/src/memutil Modified Files: memutil.lisp Log Message: Fixes for Win32 allegro build; lispwork builds but fails to run; new test of :index class keyword which fails --- /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2007/02/26 19:12:19 1.24 +++ /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2007/03/03 17:24:59 1.25 @@ -828,12 +828,13 @@ ;; This code is an attempt to allow compilation under bothe SBCL 8 and SBCL 9. ;; Thanks to Juho Snellman for this idiom. (eval-when (:compile-toplevel) - #+(and sbcl sb-unicode) (defun new-style-copy-p () + #+(and sbcl sb-unicode) (if (find-symbol "COPY-UB8-FROM-SYSTEM-AREA" "SB-KERNEL") '(:and) - '(:or))) - ) + '(:or)) + #-(and sbcl sb-unicode) + t)) (defun buffer-read-ucs1-string (bs byte-length) "Read a UCS1 string."

1 0

[elephant-cvs] CVS elephant/src/utils
by ieslick 03 Mar '07

03 Mar '07

Update of /project/elephant/cvsroot/elephant/src/utils In directory clnet:/tmp/cvs-serv18095/src/utils Modified Files: convenience.lisp Log Message: Fixes for Win32 allegro build; lispwork builds but fails to run; new test of :index class keyword which fails --- /project/elephant/cvsroot/elephant/src/utils/convenience.lisp 2007/02/24 14:52:00 1.3 +++ /project/elephant/cvsroot/elephant/src/utils/convenience.lisp 2007/03/03 17:25:00 1.4 @@ -31,10 +31,10 @@ (setf (car subsets) (nreverse (car subsets))) (nreverse subsets))) -(defun remove-keywords (key-names args) - (loop for ( name val ) on args by #'cddr - unless (member name key-names) - append (list name val))) +(defun remove-keywords (keywords list) + (cond ((null list) nil) + ((member (car list) keywords) (cddr list)) + (t (cons (car list) (remove-keywords keywords (cdr list)))))) (defun concat-separated-strings (separator &rest lists) (format nil (concatenate 'string "~{~A~^" (string separator) "~}")

1 0

[elephant-cvs] CVS elephant/src/db-bdb
by ieslick 03 Mar '07

03 Mar '07

Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory clnet:/tmp/cvs-serv18095/src/db-bdb Modified Files: berkeley-db.lisp Log Message: Fixes for Win32 allegro build; lispwork builds but fails to run; new test of :index class keyword which fails --- /project/elephant/cvsroot/elephant/src/db-bdb/berkeley-db.lisp 2007/02/17 12:13:19 1.9 +++ /project/elephant/cvsroot/elephant/src/db-bdb/berkeley-db.lisp 2007/03/03 17:24:58 1.10 @@ -21,6 +21,7 @@ (declaim #-elephant-without-optimize (optimize (speed 3) (safety 0)) + #-lispworks (inline %db-get-key-buffered db-get-key-buffered %db-get-buffered db-get-buffered db-get %db-put-buffered db-put-buffered

1 0

[elephant-cvs] CVS elephant/src/elephant
by ieslick 03 Mar '07

03 Mar '07

Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv18095/src/elephant Modified Files: classes.lisp serializer.lisp Log Message: Fixes for Win32 allegro build; lispwork builds but fails to run; new test of :index class keyword which fails --- /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2007/02/26 19:55:12 1.18 +++ /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2007/03/03 17:24:59 1.19 @@ -49,26 +49,18 @@ (defmethod ensure-class-using-class :around ((class (eql nil)) name &rest args &key index) "Support the :index class option" - (let ((result (apply #'call-next-method class name (remove-index-keyword args)))) + (let ((result (apply #'call-next-method class name (remove-keywords '(:index) args)))) (when (and index (subtypep (type-of result) 'persistent-metaclass)) (update-indexed-record result nil :class-indexed t)) result)) (defmethod ensure-class-using-class :around ((class persistent-metaclass) name &rest args &key index) "Support the :index class option on redefinition" - (let ((result (apply #'call-next-method class name (remove-index-keyword args)))) + (let ((result (apply #'call-next-method class name (remove-keywords '(:index) args)))) (when index (update-indexed-record result nil :class-indexed t)) result)) -(defun remove-index-keyword (list) - (cond ((null list) - nil) - ((eq (car list) :index) - (cddr list)) - (t - (cons (car list) (remove-index-keyword (cdr list)))))) - (defmethod shared-initialize :around ((class persistent-metaclass) slot-names &rest args &key direct-superclasses) "Ensures we inherit from persistent-object." (let* ((persistent-metaclass (find-class 'persistent-metaclass)) --- /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2007/02/26 19:12:18 1.24 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2007/03/03 17:24:59 1.25 @@ -259,10 +259,5 @@ "Shared byte-spec peformance hack; not thread safe so removed from use for serializer2" (declare (type (unsigned-byte 24) position)) -;; #+(or cmu sbcl allegro) -;; (progn (setf (cdr *resourced-byte-spec*) (* 32 position)) -;; *resourced-byte-spec*) -;; #-(or cmu sbcl allegro) - (byte 32 (* 32 position)) - ) + (byte 32 (* 32 position)))

1 0

[elephant-cvs] CVS elephant
by ieslick 03 Mar '07

03 Mar '07

Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv18095 Modified Files: TODO ele-bdb.asd Log Message: Fixes for Win32 allegro build; lispwork builds but fails to run; new test of :index class keyword which fails --- /project/elephant/cvsroot/elephant/TODO 2007/03/01 03:03:07 1.65 +++ /project/elephant/cvsroot/elephant/TODO 2007/03/03 17:24:55 1.66 @@ -20,10 +20,9 @@ - Migration: Improve scaling properties of migration so all objects do not need to be resident in memory? - Migration: Validate that graph structures with loop are copied properly - Migration: Improve printing and informative messages +- Fix class index slot option (and validate test) Lisp Support: -- Win32 builds - - Windows support for asdf-based library builds? Include 32-bit dll in release? - Validate Lispworks on PC - Validate OpenMCL pre-1.1 on Mac OS X - Validate OpenMCL 1.1 and/or 64-bit on Mac OS X? @@ -67,6 +66,7 @@ x Fix a bug where slot-makunbound on a persistent object failed to remove secondary index references for class and slot indices. Made a test to validate this. (Ian) x Fixed a bug in string serialization for char-code > #x7F (Henrik, Ties) +x Minor Bugs: x Enable with-transactions to properly process forms returning multiple values (Ian) @@ -83,6 +83,7 @@ x Orthogonal feature addition: map-index, map-class and map-instances to avoid consing (Ian) x Tests to validate new map interfaces on top of existing tests (Ian) x Added support and tests for serializing structure objects on all supported platforms (Ian) +x Fixed cygwin-ming32 -mno-cygwin build for Windows for Lispworks and Allegro (Frank, Ian) DEVELOPMENT CHECKINS: --- /project/elephant/cvsroot/elephant/ele-bdb.asd 2007/02/22 20:24:11 1.18 +++ /project/elephant/cvsroot/elephant/ele-bdb.asd 2007/03/03 17:24:58 1.19 @@ -32,24 +32,21 @@ (defmethod compiler-options ((compiler (eql :gcc)) (c bdb-c-source) &key &allow-other-keys) (append (library-directories c) (call-next-method) - (list "-ldb"))) + (list "-ldb45"))) (defmethod compiler-options ((compiler (eql :cygwin)) (c bdb-c-source) &key &allow-other-keys) (append (library-directories c) (call-next-method) - (list "-ldb"))) + (list "-ldb45"))) (defun library-directories (c) (let ((include (make-pathname :directory (get-config-option :berkeley-db-include-dir c))) (lib (make-pathname :directory (get-config-option :berkeley-db-lib-dir c)))) + #+(or windows mswindows) + (list (format nil "-L\"~A\"" lib) (format nil "-I\"~A\"" include)) + #-(or windows mswindows) (list (format nil "-L~A" lib) (format nil "-I~A" include)))) - -;;Cygwin script: -;;gcc -mno-cygwin -mwindows -c -Wall -std=c99 -L/c/DB/Berkeley\ DB\ 4.4.20/lib/ -I/c/DB/Berkeley\ DB\ 4.4.20/include/ libsleepycat.c -;;dlltool -z libsleepycat.def --export-all-symbols -e exports.o -l libsleepycat.lib libsleepycat.o -;;gcc -shared -mno-cygwin -mwindows -L/c/DB/Berkeley\ DB\ 4.4.20/bin/ -llibdb44 libsleepycat.o exports.o -o libsleepycat.dll - (defmethod foreign-libraries-to-load-first ((c bdb-c-source)) (remove-if #'(lambda (x) (null (car x))) (list

1 0

[elephant-cvs] CVS elephant
by ieslick 01 Mar '07

01 Mar '07

Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv22036 Modified Files: TODO Log Message: Cleanup --- /project/elephant/cvsroot/elephant/TODO 2007/02/26 19:12:18 1.64 +++ /project/elephant/cvsroot/elephant/TODO 2007/03/01 03:03:07 1.65 @@ -37,7 +37,7 @@ - Multi-threading stress tests? Ensure that there are conflicts and lots of serialization happening concurrently to make sure that multi-threading is in good shape (Henrik's code) - Unicode tests - - Ensure that variable length UTF-8 is automatically stored as UTF-16 + - Ensure that variable length UTF-8 reps are automatically stored as UTF-16 - Class / DB sychronization tests TASKS TO GET TO FINAL RELEASE:

1 0

[elephant-cvs] CVS elephant
by ieslick 01 Mar '07

01 Mar '07

Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv19415 Modified Files: elephant.asd Log Message: Windows build support --- /project/elephant/cvsroot/elephant/elephant.asd 2007/02/26 19:12:18 1.35 +++ /project/elephant/cvsroot/elephant/elephant.asd 2007/03/01 02:46:42 1.36 @@ -96,6 +96,62 @@ can be overridden or augmented by subclass methods" #+(or mswindows windows) (progn + (let* ((pathname (component-pathname c)) + (directory (directory-namestring pathname)) + (stdout-lines) (stderr-lines) (exit-status)) + (let ((command (format nil "~A ~{~A ~}" + (c-compiler-path c) + (compiler-options (c-compiler c) c + :input-file (format nil "\"~A\"" (namestring pathname)) + :output-file nil + :library nil)))) + #+allegro (multiple-value-setq (stdout-lines stderr-lines exit-status) + (excl.osi:command-output command :directory directory)) + #+lispworks (setf exit-status (system:call-system command :current-directory directory)) + (unless (zerop exit-status) + (error 'operation-error :component c :operation o))) + + (let ((command (format nil "dlltool -z ~A --export-all-symbols -e exports.o -l ~A ~A" + (format nil "\"~A\"" (namestring (make-pathname :type "def" :defaults pathname))) + (format nil "\"~A\"" (namestring (make-pathname :type "lib" :defaults pathname))) + (format nil "\"~A\"" (namestring (make-pathname :type "o" :defaults pathname)))))) + #+allegro (multiple-value-setq (stdout-lines stderr-lines exit-status) + (excl.osi:command-output command :directory directory)) + #+lispworks (setf exit-status (system:call-system command :current-directory directory)) + (unless (zerop exit-status) + (error 'operation-error :component c :operation o))) + + (let ((command (format nil "~A ~{~A ~}" ;; -I~A -L~A -l~A + (c-compiler-path c) + (compiler-options (c-compiler c) c + :input-file + (list (format nil "\"~A\"" (namestring + (make-pathname :type "o" :defaults pathname))) + "exports.o") + :output-file (format nil "\"~A\"" (first (output-files o c))) + :library t)))) + #+allegro (multiple-value-setq (stdout-lines stderr-lines exit-status) + (excl.osi:command-output command :directory directory)) + #+lispworks (setf exit-status (system:call-system command :current-directory directory)) + (unless (zerop exit-status) + (error 'operation-error :component c :operation o))))) + + #-(or mswindows windows) + (unless (zerop (run-shell-command + "~A ~{~A ~}" + (c-compiler-path c) + (compiler-options (c-compiler c) c + :input-file (namestring (component-pathname c)) + :output-file (namestring (first (output-files o c)))))) + (error 'operation-error :component c :operation o))) + +#| +(defmethod perform ((o compile-op) (c elephant-c-source)) + "Run the appropriate compiler for this platform on the source, getting + the specific options from 'compiler-options method. Default options + can be overridden or augmented by subclass methods" + #+(or mswindows windows) + (progn (let ((pathname (component-pathname c))) (unless (zerop (run-shell-command (format nil "~A ~{~A ~}" @@ -130,6 +186,12 @@ :input-file (namestring (component-pathname c)) :output-file (namestring (first (output-files o c)))))) (error 'operation-error :component c :operation o))) +|# + +;;Cygwin compile script: +;;gcc -mno-cygwin -mwindows -std=c99 -c libmemutil.c +;;dlltool -z libmeutil.def --export-all-symbols -e exports.o -l libmemutil.lib libmemutil.o +;;gcc -shared -mno-cygwin -mwindows libmemutil.o exports.o -o libmemutil.dll (defmethod operation-done-p ((o compile-op) (c elephant-c-source)) "Is the first generated library more recent than the source file?" @@ -167,12 +229,6 @@ (if (listp input-file) input-file (list input-file)) (when output-file (list "-o" output-file)))) -;;Cygwin script: -;;gcc -mno-cygwin -mwindows -std=c99 -c libmemutil.c -;;dlltool -z libmeutil.def --export-all-symbols -e exports.o -l libmemutil.lib libmemutil.o -;;gcc -shared -mno-cygwin -mwindows libmemutil.o exports.o -o libmemutil.dll - - (defmethod compiler-options ((compiler (eql :msvc)) (c elephant-c-source) &key input-file output-file) (declare (ignore input-file output-file)) (error "MSVC compiler option not supported yet"))

1 0

[elephant-cvs] CVS elephant/src/elephant
by ieslick 01 Mar '07

01 Mar '07

Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv19354 Added Files: query-example.lisp query.lisp Log Message: Quick hack for object filtering queries; example of first pass at constraint syntax --- /project/elephant/cvsroot/elephant/src/elephant/query-example.lisp 2007/03/01 02:45:45 NONE +++ /project/elephant/cvsroot/elephant/src/elephant/query-example.lisp 2007/03/01 02:45:45 1.1 (in-package :elephant) ;; TEST DATA (defparameter *constraint-spec* '(:BDB "/Users/eslick/Work/db/constraint/")) (defun print-name (inst) (format t "Name: ~A~%" (slot-value inst 'name))) (defpclass person () ((name :initarg :name :index t) (salary :initarg :salary :index t) (department :initarg :dept))) (defpclass department () ((name :initarg :name) (manager :initarg :manager))) (defparameter *names* '("Jacob" "Emily" "Michael" "Emma" "Joshua" "Madison" "Matthew" "Abigail" "Ethan" "Olivia" "Andrew" "Isabella" "Daniel" "Hannah" "Anthony" "Samantha" "Christopher" "Ava" "Joseph" "Ashley" )) (defun test-dataset () (let* ((greg (make-instance 'person :name "Greg" :salary 100000)) (sally (make-instance 'person :name "Sally" :salary 110000)) (mkt (make-instance 'department :name "Marketing" :manager greg)) (engr (make-instance 'department :name "Engineering" :manager sally))) (setf (slot-value greg 'department) mkt) (setf (slot-value sally 'department) engr) (with-transaction () (loop for i from 0 upto 500 do (make-instance 'person :name (format nil "~A~A" (utils:random-element *names*) i) :salary (floor (+ (* (random 1000) 150) 30000)) :department (if (= 1 (random 2)) mkt engr)))))) (defun print-person (person &optional (stream t)) (format stream "name: ~A salary: ~A dept: ~A~%" (slot-value person 'name) (slot-value person 'salary) (slot-value (slot-value person 'department) 'name))) (defun example-query1 () "Performs a query against a single class. Trivial string & integer matchingA" (map-class-query #'print-person '((person name = "Greg") (person salary >= 100000)))) (defun example-query2 (low-salary high-salary) "Parameterized query" (map-class-query #'print-person `((person salary >= ,low-salary) (person salary <= ,high-salary)))) --- /project/elephant/cvsroot/elephant/src/elephant/query.lisp 2007/03/01 02:45:45 NONE +++ /project/elephant/cvsroot/elephant/src/elephant/query.lisp 2007/03/01 02:45:45 1.1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; query.lisp -- Implement syntax for the elephant query engine ;;; ;;; Copyright (c) 2007 by Ian S. Eslick ;;; <ieslick at common-lisp.net> ;;; ;;; Elephant users are granted the rights to distribute and use this software ;;; as governed by the terms of the Lisp Limited General Public License ;;; (http://opensource.franz.com/preamble.html) also known as the LLGPL. ;;; (in-package :elephant) (defparameter *string-relation-functions* `((< . ,#'string<) (< . ,#'string<=) (> . ,#'string>) (> . ,#'string>=) (= . ,#'equal) (!= . ,(lambda (x y) (not (equal x y)))))) (defparameter *number-relation-functions* `((< . ,#'<) (> . ,#'>) (= . ,#'=) (!= . ,#'(lambda (x y) (not (= x y)))))) (defun relation-string-function (rel) (cdr (assoc rel *string-relation-functions*))) (defun relation-number-function (rel) (cdr (assoc rel *number-relation-functions*))) (defun test-relation (rel ival tvals) (assert (or (and (numberp ival) (numberp (first tvals))) (and (stringp ival) (stringp (first tvals))))) (typecase ival (string (funcall (relation-string-function rel) ival (first tvals))) (number (funcall (relation-number-function rel) ival (first tvals))))) (defun get-query-instances (constraints) (let ((list nil)) (flet ((collect (inst) (push inst list))) (declare (dynamic-extent collect)) (map-class-query #'collect constraints)))) (defun map-class-query (fn constraints) "Map instances using the query constaints to filter objects, exploiting slot indices (for last query) and stack allocated test closures" (assert (not (null constraints))) (destructuring-bind (class slot relation &rest values) (first constraints) (flet ((filter-by-relation (inst) (when (test-relation relation (slot-value inst slot) values) (funcall fn inst)))) (declare (dynamic-extent filter-by-relation)) (if (null (cdr constraints)) (if (find-inverted-index class slot) (if (= (length values) 1) (progn (map-class-index fn class slot (first values) (first values)) (map-class-index fn class slot (first values) (second values)))) (map-class #'filter-by-relation class)) (map-class-query #'filter-by-relation (cdr constraints)))))) ;; ;; Conjunctions of indices ;; ;;(defun map-classes (fn classes) ;; (map-index-list fn (mapcar #'find-class-index classes))) ;;(defun map-index-list (fn indices) ;; (dolist (index indices) ;; (map-index fn index)))

1 0