[bknr-cvs] hans changed trunk/bknr/datastore/src/data/object.lisp

[BKNR Commits]

Revision: 3690
Author: hans
URL: http://bknr.net/trac/changeset/3690

More changes relating to ALLOCATE-INSTANCE.

U   trunk/bknr/datastore/src/data/object.lisp

Modified: trunk/bknr/datastore/src/data/object.lisp
===================================================================
--- trunk/bknr/datastore/src/data/object.lisp	2008-07-30 09:36:20 UTC (rev 3689)
+++ trunk/bknr/datastore/src/data/object.lisp	2008-07-30 09:42:58 UTC (rev 3690)
@@ -454,9 +454,10 @@
       ;; If the class is NIL, it was not found in the currently
       ;; running Lisp image and objects of this class will be ignored.
       (when class
+        (setf (next-object-id (store-object-subsystem)) object-id)
         (let ((object (allocate-instance class)))
+          (assert (= object-id (slot-value object 'id)))
           (dolist (index (class-slot-indices class 'id))
-            (assert (= object-id (slot-value object 'id)))
             (index-add index object)))))))
 
 (defun snapshot-read-slots (stream layouts)
@@ -641,12 +642,14 @@
 
 (defun make-object (class-name &rest initargs)
   "Make a persistent object of class named CLASS-NAME. Calls MAKE-INSTANCE with INITARGS."
-  (with-store-guard ()
-    (execute (make-instance 'transaction
-                            :function-symbol 'tx-make-object
-                            :args (append (list class-name
-                                                :id (next-object-id (store-object-subsystem)))
-                                          initargs)))))
+  (if (in-anonymous-transaction-p)
+      (apply #'make-instance class-name initargs)
+      (with-store-guard ()
+        (execute (make-instance 'transaction
+                                :function-symbol 'tx-make-object
+                                :args (append (list class-name
+                                                    :id (next-object-id (store-object-subsystem)))
+                                              initargs))))))
 
 (defun tx-delete-object (id)
   (destroy-object (store-object-with-id id)))