August 2004 - elephant-cvs@common-lisp.net

[elephant-cvs] CVS update: Directory change: elephant/tests
by blee＠common-lisp.net 30 Aug '04

30 Aug '04

Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp.net:/tmp/cvs-serv5247/tests Log Message: Directory /project/elephant/cvsroot/elephant/tests added to the repository Date: Mon Aug 30 23:37:52 2004 Author: blee New directory elephant/tests added

1 0

[elephant-cvs] CVS update: elephant/NOTES
by blee＠common-lisp.net 30 Aug '04

30 Aug '04

Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv5190 Modified Files: NOTES Log Message: added preliminary notes on the metaclass stuff Date: Mon Aug 30 23:37:37 2004 Author: blee Index: elephant/NOTES diff -u elephant/NOTES:1.3 elephant/NOTES:1.4 --- elephant/NOTES:1.3 Sun Aug 29 09:44:47 2004 +++ elephant/NOTES Mon Aug 30 23:37:36 2004 @@ -33,10 +33,20 @@ CLASSES AND METACLASSES ----------------------- -***Andrew write your stuff here*** - Persistent classes which the user defines are declared and -instrumented by using the persistent-metaclass. +instrumented by using the persistent-metaclass. Ideally +creating persistent versions of class, slot-defintion, et al +would be enough, but in reality various implementations do +things in different ways. + +CMUCL / SBCL: their's a bit of work to make class slot +allocation and reader / writer / slot-boundp work right. + +Allegro: is using slot-boundp instead of +slot-boundp-using-class inside of shared-initialize, which +necessitates some work. + +Andrew will add some notes here in the future. ----------- COLLECTIONS

1 0

[elephant-cvs] CVS update: elephant/src/sleepycat.lisp
by blee＠common-lisp.net 30 Aug '04

30 Aug '04

Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv5168/src Modified Files: sleepycat.lisp Log Message: db-delete-* returns T on success, Nil if it couldn't find the record Date: Mon Aug 30 23:36:55 2004 Author: blee Index: elephant/src/sleepycat.lisp diff -u elephant/src/sleepycat.lisp:1.6 elephant/src/sleepycat.lisp:1.7 --- elephant/src/sleepycat.lisp:1.6 Sun Aug 29 22:41:30 2004 +++ elephant/src/sleepycat.lisp Mon Aug 30 23:36:54 2004 @@ -760,15 +760,23 @@ (flags :unsigned-int)) :returning :int) -(wrap-errno db-delete-buffered (db transaction key key-length flags) - :flags (auto-commit) - :keys ((transaction *current-transaction*)) - :declarations (declare (optimize (speed 3) (safety 0) (space 0)) - (type pointer-void db transaction) - (type array-or-pointer-char key) - (type fixnum key-length) - (type boolean auto-commit)) - :transaction transaction) +(defun db-delete-buffered (db key key-length &key auto-commit + (transaction *current-transaction*)) + (declare (optimize (speed 3) (safety 0) (space 0)) + (type pointer-void db transaction) (type array-or-pointer-char key) + (type fixnum key-length) (type boolean auto-commit)) + (let ((errno (%db-delete-buffered db transaction + key key-length + (flags :auto-commit auto-commit)))) + (declare (type fixnum errno)) + (cond ((= errno 0) t) + ((or (= errno DB_NOTFOUND) + (= errno DB_KEYEMPTY)) + nil) + ((or (= errno DB_LOCK_DEADLOCK) + (= errno DB_LOCK_NOTGRANTED)) + (throw transaction transaction)) + (t (error 'db-error :errno errno))))) (def-function ("db_del" %db-delete) ((db :pointer-void) @@ -778,17 +786,24 @@ (flags :unsigned-int)) :returning :int) -(wrap-errno db-delete (db transaction key key-length flags) - :flags (auto-commit) - :keys ((key-length (length key)) - (transaction *current-transaction*)) - :cstrings (key) - :declarations (declare (optimize (speed 3) (safety 0) (space 0)) - (type pointer-void db transaction) - (type string key) - (type fixnum key-length) - (type boolean auto-commit)) - :transaction transaction) +(defun db-delete (db key &key auto-commit (key-length (length key)) + (transaction *current-transaction*)) + (declare (optimize (speed 3) (safety 0) (space 0)) + (type pointer-void db transaction) (type string key) + (type fixnum key-length) (type boolean auto-commit)) + (with-cstrings ((key key)) + (let ((errno + (%db-delete db transaction key + key-length (flags :auto-commit auto-commit)))) + (declare (type fixnum errno)) + (cond ((= errno 0) nil) + ((or (= errno DB_NOTFOUND) + (= errno DB_KEYEMPTY)) + nil) + ((or (= errno DB_LOCK_DEADLOCK) + (= errno DB_LOCK_NOTGRANTED)) + (throw transaction transaction)) + (t (error 'db-error :errno errno)))))) ;; Transactions

1 0

[elephant-cvs] CVS update: elephant/src/metaclasses.lisp
by blee＠common-lisp.net 30 Aug '04

30 Aug '04

Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv32303/src Modified Files: metaclasses.lisp Log Message: merged in andrew's fixes: class slots, inheritence. added slot-boundp, slot-makunbound. Date: Mon Aug 30 23:15:13 2004 Author: blee Index: elephant/src/metaclasses.lisp diff -u elephant/src/metaclasses.lisp:1.2 elephant/src/metaclasses.lisp:1.3 --- elephant/src/metaclasses.lisp:1.2 Sun Aug 29 22:40:06 2004 +++ elephant/src/metaclasses.lisp Mon Aug 30 23:15:12 2004 @@ -80,14 +80,14 @@ (defmethod slot-definition-allocation ((slot-definition persistent-slot-definition)) :class) -#+(or cmu sbcl) -(defmethod initialize-internal-slot-functions ((slot persistent-slot-definition)) - (handle-optimized-accessors slot)) - (defmethod direct-slot-definition-class ((class persistent-metaclass) &rest initargs) (let ((allocation-key (getf initargs :allocation)) (transient-p (getf initargs :transient))) - (cond ((or (eq allocation-key :class) transient-p) + (cond ((and (eq allocation-key :class) transient-p) + (find-class 'transient-direct-slot-definition)) + ((and (eq allocation-key :class) (not transient-p)) + (error "Persistent class slots are not supported, try :transient t.")) + (transient-p (find-class 'transient-direct-slot-definition)) (t (find-class 'persistent-direct-slot-definition))))) @@ -95,6 +95,9 @@ (defmethod validate-superclass ((class persistent-metaclass) (super standard-class)) t) +(defmethod validate-superclass ((class standard-class) (super persistent-metaclass)) + nil) + (defgeneric persistent-p (class)) (defmethod persistent-p ((class t)) @@ -103,6 +106,9 @@ (defmethod persistent-p ((class persistent-metaclass)) t) +(defmethod persistent-p ((class persistent-slot-definition)) + t) + (defmethod effective-slot-definition-class ((class persistent-metaclass) &rest initargs) (let ((transient-p (getf initargs :transient))) (cond (transient-p @@ -110,6 +116,29 @@ (t (find-class 'persistent-effective-slot-definition))))) +#+(or cmu sbcl) +(defgeneric ensure-storage-exists (class slot-definition slot-name)) + +#+(or cmu sbcl) +(defmethod ensure-storage-exists (class slot-definition slot-name) + nil) + +#+(or cmu sbcl) +(defmethod ensure-storage-exists (class (slot-definition persistent-slot-definition) slot-name) + (let ((use-class (or (slot-definition-allocation-class slot-definition) + class))) + (when (not (assoc slot-name (class-slot-cells use-class))) + (setf (plist-value use-class 'class-slot-cells) + (append + (plist-value use-class 'class-slot-cells) + (list (cons slot-name +slot-unbound+))))))) + +#+(or cmu sbcl) +(defmethod compute-effective-slot-definition :around ((class persistent-metaclass) slot-name direct-slot-definitions) + (let ((slot-definition (call-next-method))) + (ensure-storage-exists class slot-definition slot-name) + slot-definition)) + (defun ensure-transient-chain (slot-definitions initargs) (declare (ignore initargs)) (loop for slot-definition in slot-definitions @@ -123,8 +152,6 @@ (setf (getf initargs :allocation) :class) initargs)))) -(defparameter *buffer* (make-array 1000)) - (defmacro persistent-slot-reader (instance name) `(progn (buffer-write-int (oid ,instance) *key-buf*) @@ -139,10 +166,11 @@ #-cmu (error 'unbound-slot :instance ,instance :name ,name))))) +#+(or cmu sbcl) (defun make-persistent-reader (name) (lambda (instance) (declare (optimize (speed 3)) - (type persistent instance)) + (type persistent-object instance)) (persistent-slot-reader instance name))) (defmacro persistent-slot-writer (new-value instance name) @@ -157,23 +185,39 @@ :auto-commit *auto-commit*) ,new-value))) +#+(or cmu sbcl) (defun make-persistent-writer (name) (lambda (new-value instance) (declare (optimize (speed 3)) - (type persistent instance)) + (type persistent-object instance)) (persistent-slot-writer new-value instance name))) -(defgeneric handle-optimized-accessors (slot-def)) +(defmacro persistent-slot-boundp (instance name) + `(progn + (buffer-write-int (oid ,instance) *key-buf*) + (let* ((key-length (serialize ,name *key-buf*)) + (buf (db-get-key-buffered + (controller-db *store-controller*) + (buffer-stream-buffer *key-buf*) + key-length))) + (if buf T nil)))) -(defmethod handle-optimized-accessors ((slot-def t)) - slot-def) +#+(or cmu sbcl) +(defun make-persistent-slot-boundp (name) + (lambda (instance) + (declare (optimize (speed 3)) + (type persistent-object instance)) + (persistent-slot-boundp instance name))) -(defmethod handle-optimized-accessors ((slot-def persistent-slot-definition)) +#+(or cmu sbcl) +(defmethod initialize-internal-slot-functions ((slot-def persistent-slot-definition)) (let ((name (slot-definition-name slot-def))) (setf (slot-definition-reader-function slot-def) (make-persistent-reader name)) (setf (slot-definition-writer-function slot-def) - (make-persistent-writer name))) + (make-persistent-writer name)) + (setf (slot-definition-boundp-function slot-def) + (make-persistent-slot-boundp name))) slot-def) (defun persistent-slot-names (class) @@ -181,3 +225,9 @@ (loop for slot-definition in slot-definitions when (equalp (class-of slot-definition) (find-class 'persistent-effective-slot-definition)) collect (slot-definition-name slot-definition)))) + +(defun transient-slot-names (class) + (let ((slot-definitions (class-slots class))) + (loop for slot-definition in slot-definitions + unless (persistent-p slot-definition) + collect (slot-definition-name slot-definition)))) \ No newline at end of file

1 0

[elephant-cvs] CVS update: elephant/src/elephant.lisp
by blee＠common-lisp.net 30 Aug '04

30 Aug '04

Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv32243/src Modified Files: elephant.lisp Log Message: merged in andrew's fixes: class slots, inheritence. Date: Mon Aug 30 23:14:49 2004 Author: blee Index: elephant/src/elephant.lisp diff -u elephant/src/elephant.lisp:1.6 elephant/src/elephant.lisp:1.7 --- elephant/src/elephant.lisp:1.6 Sun Aug 29 22:38:43 2004 +++ elephant/src/elephant.lisp Mon Aug 30 23:14:49 2004 @@ -63,22 +63,29 @@ #+cmu (:import-from :pcl validate-superclass - slot-definition-name standard-slot-definition standard-direct-slot-definition standard-effective-slot-definition - initialize-internal-slot-functions direct-slot-definition-class - compute-effective-slot-definition-initargs effective-slot-definition-class slot-definition-name - slot-definition-reader-function - slot-definition-writer-function + slot-definition-initfunction compute-effective-slot-definition class-slots slot-value-using-class + slot-boundp-using-class slot-definition-allocation - compute-slots) + compute-slots + + initialize-internal-slot-functions + compute-effective-slot-definition-initargs + slot-definition-reader-function + slot-definition-writer-function + slot-definition-boundp-function + slot-definition-allocation-class + class-slot-cells + plist-value + +slot-unbound+) #+cmu (:import-from :ext make-weak-pointer weak-pointer-value finalize) @@ -86,16 +93,17 @@ #+sbcl (:import-from :sb-mop validate-superclass - slot-definition-name standard-slot-definition standard-direct-slot-definition standard-effective-slot-definition direct-slot-definition-class effective-slot-definition-class slot-definition-name + slot-definition-initfunction compute-effective-slot-definition class-slots slot-value-using-class + slot-boundp-using-class slot-definition-allocation compute-slots) #+sbcl @@ -103,7 +111,12 @@ initialize-internal-slot-functions compute-effective-slot-definition-initargs slot-definition-reader-function - slot-definition-writer-function) + slot-definition-writer-function + slot-definition-boundp-function + slot-definition-allocation-class + class-slot-cells + plist-value + +slot-unbound+) #+sbcl (:import-from :sb-ext make-weak-pointer weak-pointer-value finalize) @@ -111,17 +124,17 @@ #+allegro (:import-from :clos validate-superclass - slot-definition-name standard-slot-definition - slot-definition-initargs standard-direct-slot-definition standard-effective-slot-definition direct-slot-definition-class effective-slot-definition-class slot-definition-name + slot-definition-initfunction compute-effective-slot-definition class-slots slot-value-using-class + slot-boundp-using-class slot-definition-allocation compute-slots) #+allegro

1 0

[elephant-cvs] CVS update: elephant/src/classes.lisp
by blee＠common-lisp.net 30 Aug '04

30 Aug '04

Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv32223/src Modified Files: classes.lisp Log Message: merged in andrew's fixes: class slots, inheritence. added slot-boundp, slot-makunbound. Date: Mon Aug 30 23:14:25 2004 Author: blee Index: elephant/src/classes.lisp diff -u elephant/src/classes.lisp:1.5 elephant/src/classes.lisp:1.6 --- elephant/src/classes.lisp:1.5 Sun Aug 29 22:36:18 2004 +++ elephant/src/classes.lisp Mon Aug 30 23:14:25 2004 @@ -40,7 +40,6 @@ ;;; Suite 330, Boston, MA 02111-1307 USA ;;; -;; TODO: slot-bound-p (check the database) (in-package "ELEPHANT") @@ -67,6 +66,29 @@ (apply #'call-next-method class :direct-superclasses (cons (find-class 'persistent-object) direct-superclasses) args) (call-next-method)))) +(defmethod shared-initialize :around ((instance persistent-object) slot-names &rest initargs &key &allow-other-keys) + (let* ((class (class-of instance)) + (persistent-slot-names (persistent-slot-names class))) + (flet ((persistent-slot-p (item) + (member item persistent-slot-names :test #'eq))) + (let ((transient-slot-inits + (if (eq slot-names t) + (transient-slot-names class) + (remove-if #'persistent-slot-p slot-names))) + (persistent-slot-inits + (if (eq slot-names t) persistent-slot-names + (remove-if-not #'persistent-slot-p slot-names)))) + (loop for slot-def in (class-slots class) + when (member (slot-definition-name slot-def) + persistent-slot-inits) + unless (slot-boundp-using-class class instance slot-def) + do + (let ((initfun (slot-definition-initfunction slot-def))) + (when initfun + (setf (slot-value-using-class class instance slot-def) + (funcall initfun))))) + (apply #'call-next-method instance transient-slot-inits initargs))))) + (defmethod slot-value-using-class :around (class (instance persistent-object) (slot-def persistent-slot-definition)) (declare (ignore class)) (let ((name (slot-definition-name slot-def))) @@ -77,3 +99,19 @@ (let ((name (slot-definition-name slot-def))) (persistent-slot-writer new-value instance name))) +(defmethod slot-boundp-using-class :around (class (instance persistent-object) (slot-def persistent-slot-definition)) + (declare (ignore class)) + (let ((name (slot-definition-name slot-def))) + (persistent-slot-boundp instance name))) + +(defmethod slot-makunbound-using-class :around (class (instance persistent-object) (slot-def persistent-slot-definition)) + (declare (ignore class)) + (buffer-write-int (oid instance) *key-buf*) + (let* ((key-length (serialize (slot-definition-name slot-def) *key-buf*)) + (buf (db-delete-buffered + (controller-db *store-controller*) + (buffer-stream-buffer *key-buf*) + key-length + :transaction *current-transaction* + :auto-commit *auto-commit*))))) + \ No newline at end of file

1 0

[elephant-cvs] CVS update: elephant/src/utils.lisp
by blee＠common-lisp.net 29 Aug '04

29 Aug '04

Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv9597/src Modified Files: utils.lisp Log Message: new license Date: Sun Aug 29 22:41:55 2004 Author: blee Index: elephant/src/utils.lisp diff -u elephant/src/utils.lisp:1.1 elephant/src/utils.lisp:1.2 --- elephant/src/utils.lisp:1.1 Sun Aug 29 09:47:33 2004 +++ elephant/src/utils.lisp Sun Aug 29 22:41:55 2004 @@ -12,6 +12,10 @@ ;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee ;;; <ablumberg(a)common-lisp.net> <blee(a)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

1 0

[elephant-cvs] CVS update: elephant/src/sleepycat.lisp
by blee＠common-lisp.net 29 Aug '04

29 Aug '04

Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv9047/src Modified Files: sleepycat.lisp Log Message: new license, non-interned exports (thanks Rafal Strzalinski) Date: Sun Aug 29 22:41:31 2004 Author: blee Index: elephant/src/sleepycat.lisp diff -u elephant/src/sleepycat.lisp:1.5 elephant/src/sleepycat.lisp:1.6 --- elephant/src/sleepycat.lisp:1.5 Sun Aug 29 09:55:29 2004 +++ elephant/src/sleepycat.lisp Sun Aug 29 22:41:30 2004 @@ -12,6 +12,10 @@ ;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee ;;; <ablumberg(a)common-lisp.net> <blee(a)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 @@ -39,30 +43,33 @@ (defpackage sleepycat (:use common-lisp uffi) - (:export read-int read-uint read-float read-double - write-int write-uint write-float write-double - offset-char-pointer copy-str-to-buf copy-bufs byte-length - pointer-int pointer-void array-or-pointer-char - db-env-create db-env-close db-env-open db-env-dbremove - db-env-dbrename db-env-remove - db-env-set-flags db-env-get-flags - db-create db-close db-open - db-remove db-rename db-sync db-truncate - db-get-key-buffered db-get-buffered db-get db-put-buffered db-put - db-delete-buffered db-delete - *current-transaction* db-transaction-begin db-transaction-abort - db-transaction-commit with-transaction - db-transaction-id db-env-lock-id db-env-lock-id-free - db-env-lock-get db-env-lock-put with-lock - db-env-set-timeout db-env-get-timeout - db-env-set-lock-detect db-env-get-lock-detect - db-error db-error-errno - +NULL-VOID+ +NULL-CHAR+ - DB-BTREE DB-HASH DB-QUEUE DB-RECNO DB-UNKNOWN - DB_KEYEMPTY DB_LOCK_DEADLOCK DB_LOCK_NOTGRANTED DB_NOTFOUND - DB-LOCKMODE#NG DB-LOCKMODE#READ DB-LOCKMODE#WRITE - DB-LOCKMODE#wAIT DB-LOCKMODE#IWRITE DB-LOCKMODE#IREAD - DB-LOCKMODE#IWR DB-LOCKMODE#DIRTY DB-LOCKMODE#WWRITE + (:export #:*current-transaction* + #:read-int #:read-uint #:read-float #:read-double + #:write-int #:write-uint #:write-float #:write-double + #:offset-char-pointer #:copy-str-to-buf #:copy-bufs #:byte-length + #:pointer-int #:pointer-void #:array-or-pointer-char + #:db-env-create #:db-env-close #:db-env-open #:db-env-dbremove + #:db-env-dbrename #:db-env-remove + #:db-env-set-flags #:db-env-get-flags + #:db-create #:db-close #:db-open + #:db-remove #:db-rename #:db-sync #:db-truncate + #:db-get-key-buffered #:db-get-buffered #:db-get + #:db-put-buffered #:db-put + #:db-delete-buffered #:db-delete + #:db-transaction-begin #:db-transaction-abort + #:db-transaction-commit #:with-transaction + #:db-transaction-id #:db-env-lock-id #:db-env-lock-id-free + #:db-env-lock-get #:db-env-lock-put #:with-lock + #:db-env-set-timeout #:db-env-get-timeout + #:db-env-set-lock-detect #:db-env-get-lock-detect + #:db-error #:db-error-errno + #:+NULL-VOID+ #:+NULL-CHAR+ + #:DB-BTREE #:DB-HASH #:DB-QUEUE #:DB-RECNO #:DB-UNKNOWN + #:DB_KEYEMPTY #:DB_LOCK_DEADLOCK #:DB_LOCK_NOTGRANTED + #:DB_NOTFOUND + #:DB-LOCKMODE#NG #:DB-LOCKMODE#READ #:DB-LOCKMODE#WRITE + #:DB-LOCKMODE#wAIT #:DB-LOCKMODE#IWRITE #:DB-LOCKMODE#IREAD + #:DB-LOCKMODE#IWR #:DB-LOCKMODE#DIRTY #:DB-LOCKMODE#WWRITE )) (in-package "SLEEPYCAT") @@ -71,21 +78,30 @@ ;; UFFI ;;(asdf:operate 'asdf:load-op :uffi) - ;; DSO loading + ;; DSO loading - Edit these for your system! - ;; Under linux you need to load some kind of pthread + ;; Under linux you may need to load some kind of pthread ;; library. I can't figure out which is the right one. ;; This one worked for me. There are known issues with ;; Red Hat and Berkeley DB, search google. #+linux (uffi:load-foreign-library "/lib/tls/libpthread.so.0" :module "pthread") + ;; Sleepycat: this works on linux + #-bsd + (uffi:load-foreign-library "/usr/local/BerkeleyDB.4.2/lib/libdb.so" + :module "sleepycat") + ;; this works on FreeBSD + #+bsd (uffi:load-foreign-library "/usr/local/lib/db42/libdb.so" :module "sleepycat") + + ;; Libsleepycat.so: edit this (uffi:load-foreign-library - "/home/ben/lisp/elephant/libsleepycat.so" -;; "/usr/local/share/common-lisp/elephant/libsleepycat.so" + "/usr/local/share/common-lisp/elephant/libsleepycat.so" :module "libsleepycat") + + ;; fini on user editable part (def-type pointer-int (* :int)) (def-type pointer-void :pointer-void)

1 0

[elephant-cvs] CVS update: elephant/src/serializer.lisp
by blee＠common-lisp.net 29 Aug '04

29 Aug '04

Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv7895/src Modified Files: serializer.lisp Log Message: new license, bignum bugfix, don't save class slots Date: Sun Aug 29 22:40:49 2004 Author: blee Index: elephant/src/serializer.lisp diff -u elephant/src/serializer.lisp:1.5 elephant/src/serializer.lisp:1.6 --- elephant/src/serializer.lisp:1.5 Sun Aug 29 09:54:46 2004 +++ elephant/src/serializer.lisp Sun Aug 29 22:40:49 2004 @@ -12,6 +12,10 @@ ;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee ;;; <ablumberg(a)common-lisp.net> <blee(a)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 @@ -121,10 +125,9 @@ (buffer-write-byte +negative-bignum+ bs) (buffer-write-byte +positive-bignum+ bs)) (buffer-write-int needed bs) - (loop for i fixnum from 0 below word-size - ;; shouldn't this be "below"? + (loop for i fixnum from 0 to word-size for byte-spec = (int-byte-spec i) - ;; this ldb is consing! + ;; this ldb is consing on CMUCL! ;; there is an OpenMCL function which should work ;; and non-cons for the-uint of-type (unsigned-byte 32) = (ldb byte-spec num) @@ -204,7 +207,9 @@ for slot-name = (slot-definition-name sd) with ret = () do - (when (slot-boundp o slot-name) + (when (and (slot-boundp o slot-name) + (eq :instance + (slot-definition-allocation sd))) (push (slot-value o slot-name) ret) (push slot-name ret)) finally (return ret)))

1 0

[elephant-cvs] CVS update: elephant/src/metaclasses.lisp
by blee＠common-lisp.net 29 Aug '04

29 Aug '04

Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv7868/src Modified Files: metaclasses.lisp Log Message: new license, declare optimize Date: Sun Aug 29 22:40:06 2004 Author: blee Index: elephant/src/metaclasses.lisp diff -u elephant/src/metaclasses.lisp:1.1 elephant/src/metaclasses.lisp:1.2 --- elephant/src/metaclasses.lisp:1.1 Sun Aug 29 09:47:00 2004 +++ elephant/src/metaclasses.lisp Sun Aug 29 22:40:06 2004 @@ -12,6 +12,10 @@ ;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee ;;; <ablumberg(a)common-lisp.net> <blee(a)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 @@ -137,7 +141,8 @@ (defun make-persistent-reader (name) (lambda (instance) - (declare (type persistent instance)) + (declare (optimize (speed 3)) + (type persistent instance)) (persistent-slot-reader instance name))) (defmacro persistent-slot-writer (new-value instance name) @@ -154,7 +159,8 @@ (defun make-persistent-writer (name) (lambda (new-value instance) - (declare (type persistent instance)) + (declare (optimize (speed 3)) + (type persistent instance)) (persistent-slot-writer new-value instance name))) (defgeneric handle-optimized-accessors (slot-def))

1 0