[isidorus-cvs] r268 - in branches/new-datamodel/src: model unit_tests

Lukas Giessmann lgiessmann at common-lisp.net
Thu Apr 8 09:55:12 UTC 2010


Author: lgiessmann
Date: Thu Apr  8 05:55:12 2010
New Revision: 268

Log:
new-datamodel: fixed a versioning-problem in all "delete-<xy>\ generics; added the exceptions "tm-reference-error", "missing-argument-error" and "not-mergable-error"; adapt the data-model'S unit-tests to the last modifications

Modified:
   branches/new-datamodel/src/model/datamodel.lisp
   branches/new-datamodel/src/model/exceptions.lisp
   branches/new-datamodel/src/unit_tests/datamodel_test.lisp

Modified: branches/new-datamodel/src/model/datamodel.lisp
==============================================================================
--- branches/new-datamodel/src/model/datamodel.lisp	(original)
+++ branches/new-datamodel/src/model/datamodel.lisp	Thu Apr  8 05:55:12 2010
@@ -11,12 +11,13 @@
   (:use :cl :elephant :constants)
   (:nicknames :d)
   (:import-from :exceptions
-		duplicate-identifier-error)
-  (:import-from :exceptions
-		object-not-found-error)
-  (:import-from :constants
-		*xml-string*)
+		duplicate-identifier-error
+		object-not-found-error
+		missing-argument-error
+		not-mergable-error
+		tm-reference-error)
   (:import-from :constants
+		*xml-string*
 		*instance-psi*)
   (:export ;;classes
            :TopicMapConstructC
@@ -155,15 +156,9 @@
 (in-package :datamodel)
 
 
-;;TODO: call delete-construct for all child-constructs that are:
-;;      *exist-in-revision-history => nil
-;;      *are not referenced by other constructs
-;;      --> iis, psis, sls, tids, names, occs, variants, roles
-;;TODO: mark-as-deleted should call mark-as-deleted for every owned
-;;      versioned-construct of the called construct
-;;TODO: add: add-to-version-history (parent) to all
-;;      "add-<construct>"/"delete-<construct>" generics
-;; ===>> adapt exist-in-revision-history
+
+;;TODO: mark-as-deleted should call mark-as-deleted for every owned ???
+;;      versioned-construct of the called construct, same for add-xy ???
 ;;TODO: check for duplicate identifiers after topic-creation/merge
 ;;TODO: check merge-constructs in add-topic-identifier,
 ;;      add-item-identifier/add-reifier (can merge the parent constructs
@@ -172,8 +167,6 @@
 ;;TODO: implement a macro "with-merge-construct" that merges constructs
 ;;      after some data-operations are completed (should be passed as body)
 ;;      and a merge should be done
-;;TODO: use some exceptions --> more than one type,
-;;      identifier, not-mergable merges, missing-init-args...
 
 
 
@@ -261,7 +254,11 @@
 	:accessor uri
 	:inherit t
 	:type string
-	:initform (error "From PointerC(): uri must be set for a pointer")
+	:initform (error
+		   (make-condition 'missing-argument-error
+				   :message "From PointerC(): uri must be set for a pointer"
+				   :argument-symbol 'uri
+				   :function-symbol ':uri))
 	:index t
 	:documentation "The actual value of a pointer, i.e. uri or ID.")
    (identified-construct :associate (PointerAssociationC identifier)
@@ -281,7 +278,11 @@
   ((xtm-id :initarg :xtm-id
 	   :accessor xtm-id
 	   :type string
-	   :initform (error "From TopicIdentificationC(): xtm-id must be seet for a topic-identifier")
+	   :initform (error 
+		      (make-condition 'missing-argument-error
+				      :message "From TopicIdentificationC(): xtm-id must be seet for a topic-identifier"
+				      :argument-symbol 'xtm-id
+				      :function-symbol ':xtm-id))
 	   :index t
 	   :documentation "ID of the TM this identification came from."))
   (:index t)
@@ -439,13 +440,21 @@
 (defpclass TypeAssociationC(VersionedAssociationC)
   ((type-topic :initarg :type-topic
 	       :accessor type-topic
-	       :initform (error "From TypeAssociationC(): type-topic must be set")
+	       :initform (error
+			  (make-condition 'missing-argument-error
+					  :message "From TypeAssociationC(): type-topic must be set"
+					  :argument-symbol 'type-topic
+					  :function-symbol ':type-topic))
 	       :associate TopicC
 	       :documentation "Associates this object with a topic that is used
                                as type.")
    (typable-construct :initarg :typable-construct
 		      :accessor typable-construct
-		      :initform (error "From TypeAssociationC(): typable-construct must be set")
+		      :initform (error 
+				 (make-condition 'missing-argument-error
+						 :message "From TypeAssociationC(): typable-construct must be set"
+						 :argument-symbol 'typable-construct
+						 :function-symbol ':typable-construct))
 		      :associate TypableC
 		      :documentation "Associates this object with the typable
                                       construct that is typed by the
@@ -458,13 +467,21 @@
 (defpclass ScopeAssociationC(VersionedAssociationC)
   ((theme-topic :initarg :theme-topic
 		:accessor theme-topic
-		:initform (error "From ScopeAssociationC(): theme-topic must be set")
+		:initform (error
+			   (make-condition 'missing-argument-error
+					   :message "From ScopeAssociationC(): theme-topic must be set"
+					   :argument-symbol 'theme-topic
+					   :function-symbol ':theme-topic))
 		:associate TopicC
 		:documentation "Associates this opbject with a topic that is a
                                 scopable construct.")
    (scopable-construct :initarg :scopable-construct
 		       :accessor scopable-construct
-		       :initform (error "From ScopeAssociationC(): scopable-construct must be set")
+		       :initform (error
+				  (make-condition 'missing-argument-error
+						  :message "From ScopeAssociationC(): scopable-construct must be set"
+						  :argument-symbol 'scopable-construct
+						  :function-symbol ':scopable-construct))
 		       :associate ScopableC
 		       :documentation "Associates this object with the socpable
                                        construct that is scoped by the
@@ -477,13 +494,21 @@
 (defpclass ReifierAssociationC(VersionedAssociationC)
   ((reifiable-construct :initarg :reifiable-construct
 			:accessor reifiable-construct
-			:initform (error "From ReifierAssociation(): reifiable-construct must be set")
+			:initform (error
+				   (make-condition 'missing-argument-error
+						   :message "From ReifierAssociation(): reifiable-construct must be set"
+						   :argument-symbol 'reifiable-construct
+						   :function-symbol ':reifiable-construct))
 			:associate ReifiableConstructC
 			:documentation "The actual construct which is reified
                                         by a topic.")
    (reifier-topic :initarg :reifier-topic
 		  :accessor reifier-topic
-		  :initform (error "From ReifierAssociationC(): reifier-topic must be set")
+		  :initform (error
+			     (make-condition 'missing-argument-error
+					     :message "From ReifierAssociationC(): reifier-topic must be set"
+					     :argument-symbol 'reifier-topic
+					     :function-symbol ':reifier-topic))
 		  :associate TopicC
 		  :documentation "The reifier-topic that reifies the
                                   reifiable-construct."))
@@ -496,7 +521,11 @@
   ((identifier :initarg :identifier
 	       :accessor identifier
 	       :inherit t
-	       :initform (error "From PointerAssociationC(): identifier must be set")
+	       :initform (error
+			  (make-condition 'missing-argument-error
+					  :message "From PointerAssociationC(): identifier must be set"
+					  :argument-symbol 'identifier
+					  :function-symbol ':identifier))
 	       :associate PointerC
 	       :documentation "The actual data that is associated with
                                the pointer-association's parent."))
@@ -507,7 +536,11 @@
 (defpclass SubjectLocatorAssociationC(PointerAssociationC)
   ((parent-construct :initarg :parent-construct
 		     :accessor parent-construct
-		     :initform (error "From SubjectLocatorAssociationC(): parent-construct must be set")
+		     :initform (error
+				(make-condition 'missing-argument-error
+						:message "From SubjectLocatorAssociationC(): parent-construct must be set"
+						:argument-symbol 'parent-construct
+						:function-symbol ':parent-symbol))
 		     :associate TopicC
 		     :documentation "The actual topic which is associated
                                      with the subject-locator."))
@@ -518,7 +551,11 @@
 (defpclass PersistentIdAssociationC(PointerAssociationC)
   ((parent-construct :initarg :parent-construct
 		     :accessor parent-construct
-		     :initform (error "From PersistentIdAssociationC(): parent-construct must be set")
+		     :initform (error
+				(make-condition 'missing-argument-error
+						:message "From PersistentIdAssociationC(): parent-construct must be set"
+						:argument-symbol 'parent-construct
+						:function-symbol ':parent-construct))
 		     :associate TopicC
 		     :documentation "The actual topic which is associated
                                      with the subject-identifier/psi."))
@@ -529,7 +566,11 @@
 (defpclass TopicIdAssociationC(PointerAssociationC)
   ((parent-construct :initarg :parent-construct
 		     :accessor parent-construct
-		     :initform (error "From TopicIdAssociationC(): parent-construct must be set")
+		     :initform (error
+				(make-condition 'missing-arguement-error
+						:message "From TopicIdAssociationC(): parent-construct must be set"
+						:argument-symbol 'parent-construct
+						:function-symbol ':parent-construct))
 		     :associate TopicC
 		     :documentation "The actual topic which is associated
                                      with the topic-identifier."))
@@ -540,7 +581,11 @@
 (defpclass ItemIdAssociationC(PointerAssociationC)
   ((parent-construct :initarg :parent-construct
 		     :accessor parent-construct
-		     :initform (error "From ItemIdAssociationC(): parent-construct must be set")
+		     :initform (error 
+				(make-condition 'missing-argument-error
+						:message "From ItemIdAssociationC(): parent-construct must be set"
+						:argument-symbol 'parent-construct
+						:function-symbol ':parent-construct))
 		     :associate ReifiableConstructC
 		     :documentation "The actual parent which is associated
                                      with the item-identifier."))
@@ -553,7 +598,11 @@
   ((characteristic :initarg :characteristic
 		   :accessor characteristic
 		   :inherit t
-		   :initform (error "From CharacteristicCAssociation(): characteristic must be set")
+		   :initform (error
+			      (make-condition 'missing-argument-error
+					      :message "From CharacteristicCAssociation(): characteristic must be set"
+					      :argument-symbol 'characteristic
+					      :function-symbol ':characteristic))
 		   :associate CharacteristicC
 		   :documentation "Associates this object with the actual
                                    characteristic object."))
@@ -564,7 +613,11 @@
 (defpclass VariantAssociationC(CharacteristicAssociationC)
   ((parent-construct :initarg :parent-construct
 		     :accessor parent-construct
-		     :initform (error "From VariantAssociationC(): parent-construct must be set")
+		     :initform (error
+				(make-condition 'missing-argument-error
+						:message "From VariantAssociationC(): parent-construct must be set"
+						:argument-symbol 'parent-construct
+						:function-symbol ':parent-construct))
 		     :associate NameC
 		     :documentation "Associates this object with a name."))
   (:documentation "Associates variant objects with name obejcts.
@@ -574,7 +627,11 @@
 (defpclass NameAssociationC(CharacteristicAssociationC)
   ((parent-construct :initarg :parent-construct
 		     :accessor parent-construct
-		     :initform (error "From NameAssociationC(): parent-construct must be set")
+		     :initform (error
+				(make-condition 'missing-argument-error
+						:message "From NameAssociationC(): parent-construct must be set"
+						:argument-symbol 'parent-construct
+						:function-symbol ':parent-construct))
 		     :associate TopicC
 		     :documentation "Associates this object with a topic."))
   (:documentation "Associates name objects with their parent topics.
@@ -584,7 +641,11 @@
 (defpclass OccurrenceAssociationC(CharacteristicAssociationC)
   ((parent-construct :initarg :parent-construct
 		     :accessor parent-construct
-		     :initform (error "From OccurrenceAssociationC(): parent-construct must be set")
+		     :initform (error
+				(make-condition 'missing-argument-error
+						:message "From OccurrenceAssociationC(): parent-construct must be set"
+						:argument-symbol 'parent-construct
+						:function-symbol ':parent-construct))
 		     :associate TopicC
 		     :documentation "Associates this object with a topic."))
   (:documentation "Associates occurrence objects with their parent topics.
@@ -596,13 +657,21 @@
   ((player-topic :initarg :player-topic
 		 :accessor player-topic
 		 :associate TopicC
-		 :initform (error "From PlayerAssociationC(): player-topic must be set")
+		 :initform (error
+			    (make-condition 'missing-argument-error
+					    :message "From PlayerAssociationC(): player-topic must be set"
+					    :argument-symbol 'player-topic
+					    :function-symbol ':player-topic))
 		 :documentation "Associates this object with a topic that is
                                  a player.")
    (parent-construct :initarg :parent-construct
 		     :accessor parent-construct
 		     :associate RoleC
-		     :initform (error "From PlayerAssociationC(): parent-construct must be set")
+		     :initform (error
+				(make-condition 'missing-argument-error
+						:message "From PlayerAssociationC(): parent-construct must be set"
+						:argument-symbol 'parent-construct
+						:function-symbol ':parent-construct))
 		     :documentation "Associates this object with the parent-association."))
   (:documentation "This class associates roles and their player in given
                    revisions."))
@@ -612,12 +681,20 @@
   ((role :initarg :role
 	 :accessor role
 	 :associate RoleC
-	 :initform (error "From RoleAssociationC(): role must be set")
+	 :initform (error
+		    (make-condition 'missing-argument-error
+				    :message "From RoleAssociationC(): role must be set"
+				    :argument-symbol 'role
+				    :function-symbol ':role))
 	 :documentation "Associates this objetc with a role-object.")
    (parent-construct :initarg :parent-construct
 		     :accessor parent-construct
 		     :associate AssociationC
-		     :initform (error "From RoleAssociationC(): parent-construct  must be set")
+		     :initform (error
+				(make-condition 'missing-argument-error
+						:message "From RoleAssociationC(): parent-construct  must be set"
+						:argument-symbol 'parent-construct
+						:function-symbol ':parent-construct))
 		     :documentation "Assocates thius object with an
                                      association-object."))
   (:documentation "Associates roles with assoications and adds some
@@ -763,6 +840,11 @@
 
 
 ;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defgeneric delete-if-not-referenced (construct)
+  (:documentation "Calls delete-construct for the given object if it is
+                   not referenced by any other construct."))
+
+
 (defgeneric add-characteristic (construct characteristic &key revision)
   (:documentation "Adds the passed characterisitc to the given topic by calling
                    add-name or add-occurrences.
@@ -955,7 +1037,11 @@
 (defgeneric add-to-version-history (construct &key start-revision end-revision)
   (:documentation "Adds version history to a versioned construct")
   (:method ((construct VersionedConstructC)
-	    &key (start-revision (error "From add-to-version-history(): start revision must be present"))
+	    &key (start-revision (error
+				  (make-condition 'missing-argument-error
+						  :message "From add-to-version-history(): start revision must be present"
+						  :argument-symbol 'start-revision
+						  :function-symbol 'add-to-version-history)))
 	    (end-revision 0))
     (let ((eql-version-info
 	   (find-if #'(lambda(vi)
@@ -1370,7 +1456,6 @@
 			    construct xtm-id))))
 	  (uri (first possible-identifiers)))
 	(concatenate 'string "t" (write-to-string (internal-id construct))))))
-       
 
 
 (defgeneric topic-identifiers (construct &key revision)
@@ -1422,13 +1507,16 @@
   (:documentation "Sets the association object between the passed constructs
                    as mark-as-deleted.")
   (:method ((construct TopicC) (topic-identifier TopicIdentificationC)
-	    &key (revision (error "From delete-topic-identifier(): revision must be set")))
+	    &key (revision (error (make-condition 'missing-argument-error
+						  :message "From delete-topic-identifier(): revision must be set"
+						  :argument-symbol 'revision
+						  :function-symbol 'delete-topic-identifier))))
     (let ((assoc-to-delete (loop for ti-assoc in (slot-p construct 'topic-identifiers)
 			      when (eql (identifier ti-assoc) topic-identifier)
 			      return ti-assoc)))
       (when assoc-to-delete
-	(mark-as-deleted assoc-to-delete :revision revision))
-      (add-to-version-history construct :start-revision revision)
+	(mark-as-deleted assoc-to-delete :revision revision)
+	(add-to-version-history construct :start-revision revision))
       construct)))
 
 
@@ -1478,13 +1566,16 @@
   (:documentation "Sets the association object between the passed constructs
                    as mark-as-deleted.")
   (:method ((construct TopicC) (psi PersistentIdC)
-	    &key (revision (error "From delete-psi(): revision must be set")))
+	    &key (revision (error (make-condition 'missing-argument-error
+						  :message "From delete-psi(): revision must be set"
+						  :argument-symbol 'revision
+						  :function-symbol 'delete-psi))))
     (let ((assoc-to-delete (loop for psi-assoc in (slot-p construct 'psis)
 			      when (eql (identifier psi-assoc) psi)
 			      return psi-assoc)))
       (when assoc-to-delete
-	(mark-as-deleted assoc-to-delete :revision revision))
-      (add-to-version-history construct :start-revision revision)
+	(mark-as-deleted assoc-to-delete :revision revision)
+	(add-to-version-history construct :start-revision revision))
       construct)))
 
 
@@ -1535,13 +1626,16 @@
   (:documentation "Sets the association object between the passed constructs
                    as mark-as-deleted.")
   (:method ((construct TopicC) (locator SubjectLocatorC)
-	    &key (revision (error "From delete-locator(): revision must be set")))
+	    &key (revision (error (make-condition 'missing-argument-error
+						  :message "From delete-locator(): revision must be set"
+						  :argument-symbol 'revision
+						  :function-symbol 'delete-locator))))
     (let ((assoc-to-delete (loop for loc-assoc in (slot-p construct 'locators)
 			      when (eql (identifier loc-assoc) locator)
 			      return loc-assoc)))
       (when assoc-to-delete
-	(mark-as-deleted assoc-to-delete :revision revision))
-      (add-to-version-history construct :start-revision revision)
+	(mark-as-deleted assoc-to-delete :revision revision)
+	(add-to-version-history construct :start-revision revision))
       construct)))
 
 
@@ -1572,8 +1666,12 @@
 	    &key (revision *TM-REVISION*))
     (when (and (parent name :revision revision)
 	       (not (eql (parent name :revision revision) construct)))
-      (error "From add-name(): ~a can't be owned by ~a since it is already owned by the topic ~a"
-	     name construct (parent name :revision revision)))
+      (error (make-condition 'tm-reference-error
+			     :message (format nil "From add-name(): ~a can't be owned by ~a since it is already owned by the topic ~a"
+					      name construct (parent name :revision revision))
+			     :referenced-construct name
+			     :existing-reference (parent name :revision revision)
+			     :new-reference construct)))
     (let ((all-names
 	   (map 'list #'characteristic (slot-p construct 'names))))
       (if (find name all-names)
@@ -1594,13 +1692,16 @@
   (:documentation "Sets the association object between the passed constructs
                    as mark-as-deleted.")
   (:method ((construct TopicC) (name NameC)
-	    &key (revision (error "From delete-name(): revision must be set")))
+	    &key (revision (error (make-condition 'missing-argument-error
+						  :message "From delete-name(): revision must be set"
+						  :argument-symbol 'revision
+						  :function-symbol 'delete-name))))
     (let ((assoc-to-delete (loop for name-assoc in (slot-p construct 'names)
 			      when (eql (characteristic name-assoc) name)
 			      return name-assoc)))
       (when assoc-to-delete
-	(mark-as-deleted assoc-to-delete :revision revision))
-      (add-to-version-history construct :start-revision revision)
+	(mark-as-deleted assoc-to-delete :revision revision)
+	(add-to-version-history construct :start-revision revision))
       construct)))
 
 
@@ -1623,8 +1724,12 @@
 	    &key (revision *TM-REVISION*))
     (when (and (parent occurrence :revision revision)
 	       (not (eql (parent occurrence :revision revision) construct)))
-      (error "From add-occurrence(): ~a can't be owned by ~a since it is already owned by the topic ~a"
-	     occurrence construct (parent occurrence :revision revision)))
+      (error 'tm-reference-error
+	     :message (format nil "From add-occurrence(): ~a can't be owned by ~a since it is already owned by the topic ~a"
+			      occurrence construct (parent occurrence :revision revision))
+	     :referenced-construct occurrence
+	     :existing-reference (parent occurrence :revision revision)
+	     :new-reference construct))
     (let ((all-occurrences
 	   (map 'list #'characteristic (slot-p construct 'occurrences))))
       (if (find occurrence all-occurrences)
@@ -1644,13 +1749,16 @@
   (:documentation "Sets the association object between the passed constructs
                    as mark-as-deleted.")
   (:method ((construct TopicC) (occurrence OccurrenceC)
-	    &key (revision (error "From delete-occurrence(): revision must be set")))
+	    &key (revision (error (make-condition 'missing-argument-error
+						  :message "From delete-occurrence(): revision must be set"
+						  :argument-symbol 'revision
+						  :function-symbol 'delete-construct))))
     (let ((assoc-to-delete (loop for occ-assoc in (slot-p construct 'occurrences)
 			      when (eql (characteristic occ-assoc) occurrence)
 			      return occ-assoc)))
       (when assoc-to-delete
-	(mark-as-deleted assoc-to-delete :revision revision))
-      (add-to-version-history construct :start-revision revision)
+	(mark-as-deleted assoc-to-delete :revision revision)
+	(add-to-version-history construct :start-revision revision))
       construct)))
 
 
@@ -1777,7 +1885,9 @@
 		 (when (find-item-by-revision top-from-oid revision)
 		   top-from-oid))))))
     (if (and error-if-nil (not result))
-        (error "No such item (id: ~a, tm: ~a, rev: ~a)" topic-id xtm-id revision)
+        (error (make-condition 'object-not-found-error
+			       :message (format nil "No such item (id: ~a, tm: ~a, rev: ~a)"
+						topic-id xtm-id revision)))
         result)))
 
 
@@ -1802,12 +1912,13 @@
 				      :uri uri)))
 	     (identified-construct (first possible-ids)
 				   :revision revision)))))
-	     ;no revision need not to be checked, since the revision
+	     ;no revision need to be checked, since the revision
              ;is implicitely checked by the function identified-construct
     (if result
 	result
 	(when error-if-nil
-	  (error "No such item is bound to the given identifier uri.")))))
+	  (error (make-condition 'object-not-found-error
+				 :message "No such item is bound to the given identifier uri."))))))
 
 
 (defun get-item-by-item-identifier (uri &key (revision *TM-REVISION*)
@@ -1887,6 +1998,13 @@
 
 
 ;;; CharacteristicC
+(defmethod delete-if-not-referenced ((construct CharacteristicC))
+  (let ((references (slot-p construct 'parent)))
+    (when (and (<= (length references) 1)
+	       (marked-as-deleted-p (first references)))
+      (delete-construct construct))))
+
+
 (defmethod find-oldest-construct ((construct-1 CharacteristicC)
 				  (construct-2 CharacteristicC))
   (let ((vi-1 (find-version-info (slot-p construct-1 'parent)))
@@ -2003,8 +2121,12 @@
 	    return parent-assoc)))
     (when (and already-set-parent
 	       (not (eql already-set-parent parent-construct)))
-      (error "From add-parent(): ~a can't be owned by ~a since it is already owned by ~a"
-	     construct parent-construct already-set-parent))
+      (error (make-condition 'tm-reference-error
+			     :message (format nil "From add-parent(): ~a can't be owned by ~a since it is already owned by ~a"
+					      construct parent-construct already-set-parent)
+			     :referenced-construct construct
+			     :existing-reference (parent construct :revision revision)
+			     :new-reference parent-construct)))
     (cond (already-set-parent
 	   (let ((parent-assoc
 		  (loop for parent-assoc in (slot-p construct 'parent)
@@ -2032,15 +2154,18 @@
 
 (defmethod delete-parent ((construct CharacteristicC)
 			  (parent-construct ReifiableConstructC)
-			  &key (revision (error "From delete-parent(): revision must be set")))
+			  &key (revision (error (make-condition 'missing-argument-error
+								:message "From delete-parent(): revision must be set"
+								:argument-symbol 'revision
+								:function-symbol 'delete-parent))))
   (let ((assoc-to-delete
 	 (loop for parent-assoc in (slot-p construct 'parent)
 	    when (eql (parent-construct parent-assoc) parent-construct)
 	    return parent-assoc)))
     (when assoc-to-delete
-      (mark-as-deleted assoc-to-delete :revision revision))
-    (when (typep parent-construct 'VersionedConstructC)
-      (add-to-version-history parent-construct :start-revision revision))
+      (mark-as-deleted assoc-to-delete :revision revision)
+      (when (typep parent-construct 'VersionedConstructC)
+	(add-to-version-history parent-construct :start-revision revision)))
     construct))
 
 
@@ -2159,8 +2284,12 @@
 	    &key (revision *TM-REVISION*))
     (when (and (parent variant :revision revision)
 	       (not (eql (parent variant :revision revision) construct)))
-      (error "From add-variant(): ~a can't be owned by ~a since it is already owned by the name ~a"
-	     variant construct (parent variant :revision revision)))
+      (error (make-condition 'tm-reference-error
+			     :message (format nil "From add-variant(): ~a can't be owned by ~a since it is already owned by the name ~a"
+					      variant construct (parent variant :revision revision))
+			     :referenced-construct variant
+			     :existing-reference (parent variant :revision revision)
+			     :new-reference construct)))
     (let ((all-variants 
 	   (map 'list #'characteristic (slot-p construct 'variants))))
       (if (find variant all-variants)
@@ -2180,7 +2309,10 @@
   (:documentation "Deletes the passed variant by marking it's association as
                    deleted in the passed revision.")
   (:method ((construct NameC) (variant VariantC)
-	    &key (revision (error "From delete-variant(): revision must be set")))
+	    &key (revision (error (make-condition 'missing-argument-error
+						  :message "From delete-variant(): revision must be set"
+						  :argument-symbol 'revision
+						  :function-symbol 'delete-variant))))
     (let ((assoc-to-delete (loop for variant-assoc in (slot-p construct
 							      'variants)
 			      when (eql (characteristic variant-assoc) variant)
@@ -2305,13 +2437,16 @@
   (:documentation "Deletes the passed role by marking it's association as
                    deleted in the passed revision.")
   (:method ((construct AssociationC) (role RoleC)
-	    &key (revision (error "From delete-role(): revision must be set")))
+	    &key (revision (error (make-condition 'missing-argument-error
+						  :message "From delete-role(): revision must be set"
+						  :argument-symbol 'revision
+						  :function-symbol 'delete-role))))
     (let ((assoc-to-delete (loop for role-assoc in (slot-p construct 'roles)
 			      when (eql (role role-assoc) role)
 			      return role-assoc)))
       (when assoc-to-delete
-	(mark-as-deleted assoc-to-delete :revision revision))
-      (add-to-version-history construct :start-revision revision)
+	(mark-as-deleted assoc-to-delete :revision revision)
+	(add-to-version-history construct :start-revision revision))
       construct)))
 
 
@@ -2320,6 +2455,13 @@
 
 
 ;;; RoleC
+(defmethod delete-if-not-referenced ((construct RoleC))
+  (let ((references (slot-p construct 'parent)))
+    (when (and (<= (length references) 1)
+	       (marked-as-deleted-p (first references)))
+      (delete-construct construct))))
+
+
 (defmethod find-oldest-construct ((construct-1 RoleC) (construct-2 RoleC))
   (let ((vi-1 (find-version-info (slot-p construct-1 'parent)))
 	(vi-2 (find-version-info (slot-p construct-2 'parent))))
@@ -2429,8 +2571,12 @@
 			      return parent-assoc)))
     (when (and already-set-parent
 	       (not (eql already-set-parent parent-construct)))
-      (error "From add-parent(): ~a can't be owned by ~a since it is already owned by ~a"
-	     construct parent-construct already-set-parent))
+      (error (make-condition 'tm-reference-error
+			     :message (format nil "From add-parent(): ~a can't be owned by ~a since it is already owned by ~a"
+					      construct parent-construct already-set-parent)
+			     :referenced-construct construct
+			     :existing-reference (parent construct :revision revision)
+			     :new-reference parent-construct)))
     (cond (already-set-parent
 	   (let ((parent-assoc
 		  (loop for parent-assoc in (slot-p construct 'parent)
@@ -2450,14 +2596,17 @@
 
 
 (defmethod delete-parent ((construct RoleC) (parent-construct AssociationC)
-	    &key (revision (error "From delete-parent(): revision must be set")))
+	    &key (revision (error (make-condition 'missing-argument-error
+						  :message "From delete-parent(): revision must be set"
+						  :argument-symbol 'revision
+						  :function-symbol 'delete-parent))))
   (let ((assoc-to-delete
 	 (loop for parent-assoc in (slot-p construct 'parent)
 	    when (eql (parent-construct parent-assoc) parent-construct)
 	    return parent-assoc)))
     (when assoc-to-delete
-      (mark-as-deleted assoc-to-delete :revision revision))
-    (add-to-version-history parent-construct :start-revision revision)
+      (mark-as-deleted assoc-to-delete :revision revision)
+      (add-to-version-history parent-construct :start-revision revision))
     construct))
 
 
@@ -2483,8 +2632,12 @@
 	      return player-assoc)))
       (when (and already-set-player
 		 (not (eql already-set-player player-topic)))
-	(error "From add-player(): ~a can't be played by ~a since it is played by ~a"
-	       construct player-topic already-set-player))
+	(error (make-condition 'tm-reference-error
+			       :message (format nil "From add-player(): ~a can't be played by ~a since it is played by ~a"
+						construct player-topic already-set-player)
+			       :referenced-construct construct
+			       :existing-reference (player construct :revision revision)
+			       :new-reference player-topic)))
       (cond (already-set-player
 	     (let ((player-assoc
 		    (loop for player-assoc in (slot-p construct 'player)
@@ -2505,7 +2658,10 @@
   (:documentation "Deletes the passed topic as a player of the passed role 
                    object by marking its association-object as deleted.")
   (:method ((construct RoleC) (player-topic TopicC)
-	    &key (revision (error "From delete-parent(): revision must be set")))
+	    &key (revision (error (make-condition 'missing-argument-error
+						  :message "From delete-parent(): revision must be set"
+						  :argument-symbol 'revision
+						  :function-symbol 'delete-player))))
     (let ((assoc-to-delete
 	   (loop for player-assoc in (slot-p construct 'player)
 	      when (eql (parent-construct player-assoc) construct)
@@ -2652,14 +2808,17 @@
   (:documentation "Sets the association object between the passed constructs
                    as mark-as-deleted.")
   (:method ((construct ReifiableConstructC) (item-identifier ItemIdentifierC)
-	    &key (revision (error "From delete-item-identifier(): revision must be set")))
+	    &key (revision (error (make-condition 'missing-argument-error
+						  :message "From delete-item-identifier(): revision must be set"
+						  :argument-symbol 'revision
+						  :function-symbol 'delete-item-identifier))))
     (let ((assoc-to-delete (loop for ii-assoc in (slot-p construct 'item-identifiers)
 			      when (eql (identifier ii-assoc) item-identifier)
 			      return ii-assoc)))
       (when assoc-to-delete
-	(mark-as-deleted assoc-to-delete :revision revision))
-      (when (typep construct 'VersionedConstructC)
-	(add-to-version-history construct :start-revision revision))
+	(mark-as-deleted assoc-to-delete :revision revision)
+	(when (typep construct 'VersionedConstructC)
+	  (add-to-version-history construct :start-revision revision)))
       construct)))
 
 
@@ -2706,14 +2865,17 @@
   (:documentation "Sets the association object between the passed constructs
                    as mark-as-deleted.")
   (:method ((construct ReifiableConstructC) (reifier TopicC)
-	    &key (revision (error "From delete-reifier(): revision must be set")))
+	    &key (revision (error (make-condition 'missing-argument-error
+						  :message "From delete-reifier(): revision must be set"
+						  :argument-symbol 'revision
+						  :function-symbol 'delete-reifier))))
     (let ((assoc-to-delete (loop for reifier-assoc in (slot-p construct 'reifier)
 			      when (eql (reifier-topic reifier-assoc) reifier)
 			      return reifier-assoc)))
       (when assoc-to-delete
-	(mark-as-deleted assoc-to-delete :revision revision))
-      (when (typep construct 'VersionedConstructC)
-	(add-to-version-history construct :start-revision revision))
+	(mark-as-deleted assoc-to-delete :revision revision)
+	(when (typep construct 'VersionedConstructC)
+	  (add-to-version-history construct :start-revision revision)))
       construct)))
 
 
@@ -2824,7 +2986,10 @@
   (:documentation "Deletes the passed theme by marking it's association as
                    deleted in the passed revision.")
   (:method ((construct ScopableC) (theme-topic TopicC)
-	    &key (revision (error "From delete-theme(): revision must be set")))
+	    &key (revision (error (make-condition 'missing-argument-error
+						  :message "From delete-theme(): revision must be set"
+						  :argument-symbol 'revsion
+						  :function-symbol 'delete-theme))))
     (let ((assoc-to-delete (loop for theme-assoc in (slot-p construct 'themes)
 			      when (eql (theme-topic theme-assoc) theme-topic)
 			      return theme-assoc)))
@@ -2873,8 +3038,12 @@
 	      return type-assoc)))
       (when (and already-set-type
 		 (not (eql type-topic already-set-type)))
-	(error "From add-type(): ~a can't be typed by ~a since it is typed by ~a"
-	       construct type-topic already-set-type))
+	(error (make-condition 'tm-reference-error
+			       :message (format nil "From add-type(): ~a can't be typed by ~a since it is typed by ~a"
+						construct type-topic already-set-type)
+			       :referenced-construct construct
+			       :existing-reference (instance-of construct :revision revision)
+			       :new-reference type-topic)))
       (cond (already-set-type
 	     (let ((type-assoc
 		    (loop for type-assoc in (slot-p construct 'instance-of)
@@ -2897,7 +3066,10 @@
   (:documentation "Deletes the passed type by marking it's association as
                    deleted in the passed revision.")
   (:method ((construct TypableC) (type-topic TopicC)
-	    &key (revision (error "From delete-type(): revision must be set")))
+	    &key (revision (error (make-condition 'missing-argument-error
+						  :message "From delete-type(): revision must be set"
+						  :argument-symbol 'revision
+						  :function-symbol 'delete-type))))
     (let ((assoc-to-delete
 	   (loop for type-assoc in (slot-p construct 'instance-of)
 	      when (eql (type-topic type-assoc) type-topic)
@@ -2986,7 +3158,10 @@
 		 (and (ReifiableConstructC-p class-symbol)
 		      (or (getf args :item-identifiers) (getf args :reifier))))
 	     (not (getf args :start-revision)))
-    (error "From make-construct(): start-revision must be set"))
+    (error (make-condition 'missing-argument-error
+			   :message "From make-construct(): start-revision must be set"
+			   :argument-symbol 'start-revision
+			   :function-symbol 'make-construct)))
   (let ((construct
 	 (cond
 	   ((PointerC-p class-symbol)
@@ -3034,7 +3209,10 @@
 	(roles (getf args :roles)))
     (when (and (or roles instance-of themes)
 	       (not start-revision))
-      (error "From make-association(): start-revision must be set"))
+      (error (make-condition 'missing-argument-error
+			     :message "From make-association(): start-revision must be set"
+			     :argument-symbol 'start-revision
+			     :function-symbol 'make-association)))
     (let ((association
 	   (let ((existing-associations
 		  (remove-if
@@ -3071,7 +3249,10 @@
 	(start-revision (getf args :start-revision)))
     (when (and (or instance-of player parent)
 	       (not start-revision))
-      (error "From make-role(): start-revision must be set"))
+      (error (make-condition 'missing-argument-error
+			     :message "From make-role(): start-revision must be set"
+			     :argument-symbol 'start-revision
+			     :function-symbol 'make-role)))
     (let ((role
 	   (let ((existing-roles
 		  (when parent
@@ -3109,7 +3290,10 @@
 	(start-revision (getf args :start-revision)))
     (when (and (or item-identifiers reifier)
 	       (not start-revision))
-      (error "From make-tm(): start-revision must be set"))
+      (error (make-condition 'missing-argument-error
+			     :message "From make-tm(): start-revision must be set"
+			     :argument-symbol 'start-revision
+			     :function-symbol 'make-tm)))
     (let ((tm
 	   (let ((existing-tms
 		  (remove-if
@@ -3146,7 +3330,10 @@
     (when (and (or psis locators item-identifiers topic-identifiers
 		   names occurrences)
 	       (not start-revision))
-      (error "From make-topic(): start-revision must be set"))
+      (error (make-condition 'missing-argument-error
+			     :message "From make-topic(): start-revision must be set"
+			     :argument-symbol 'start-revision
+			     :function-symbol 'make-topic)))
     (let ((topic
 	   (let ((existing-topics
 		  (remove-if
@@ -3199,7 +3386,10 @@
 	(parent (getf args :parent)))
     (when (and (or instance-of themes variants parent)
 	       (not start-revision))
-      (error "From make-characteristic(): start-revision must be set"))
+      (error (make-condition 'missing-argument-error
+			     :message "From make-characteristic(): start-revision must be set"
+			     :argument-symbol 'start-revsion
+			     :function-symbol 'make-characgteristic)))
     (let ((characteristic
 	   (let ((existing-characteristic
 		  (when parent
@@ -3235,12 +3425,21 @@
 	(identified-construct (getf args :identified-construct))
 	(err "From make-pointer(): "))
     (when (and identified-construct (not start-revision))
-      (error "~astart-revision must be set" err))
+      (error (make-condition 'missing-argument-error
+			     :message (format nil "~astart-revision must be set" err)
+			     :argument-symbol 'start-revision
+			     :function-symbol 'make-pointer)))
     (unless uri
-      (error "~auri must be set" err))
+      (error (make-condition 'missing-argument-error
+			     :message (format nil "~auri must be set" err)
+			     :argument-symbol 'uri
+			     :function-symbol 'make-pointer)))
     (when (and (TopicIdentificationC-p class-symbol)
 	       (not xtm-id))
-      (error "~axtm-id must be set" err))
+      (error (make-condition 'missing-argument-error
+			     :message (format nil "~axtm-id must be set" err)
+			     :argument-symbol 'xtm-id
+			     :function-symbol 'make-pointer)))
     (let ((identifier
 	   (let ((existing-pointer
 		  (remove-if
@@ -3396,8 +3595,11 @@
 	  (destination-reified (reified-construct destination
 						  :revision revision)))
       (unless (eql (type-of source-reified) (type-of destination-reified))
-	(error "From move-reified-construct(): ~a and ~a can't be merged since the reified-constructs are not of the same type ~a ~a"
-	       source destination source-reified destination-reified))
+	(error (make-condition 'not-mergable-error
+			       :message (format nil "From move-reified-construct(): ~a and ~a can't be merged since the reified-constructs are not of the same type ~a ~a"
+						source destination source-reified destination-reified)
+			       :construct-1 source
+			       :construct-2 destination)))
       (cond ((and source-reified destination-reified)
 	     (delete-reifier source-reified source :revision revision)
 	     (delete-reifier destination-reified destination :revision revision)
@@ -3551,8 +3753,11 @@
 		(parent-2 (parent newer-char :revision revision)))
 	    (unless (strictly-equivalent-constructs construct-1 construct-2
 						    :revision revision)
-	      (error "From merge-constructs(): ~a and ~a are not mergable"
-		     construct-1 construct-2))
+	      (error (make-condition 'not-mergable-error
+				     :message (format nil "From merge-constructs(): ~a and ~a are not mergable"
+						      construct-1 construct-2)
+				     :construct-1 construct-1
+				     :construct-2 construct-2)))
 	    (cond ((and parent-1 (eql parent-1 parent-2))
 		   (move-referenced-constructs newer-char older-char
 					       :revision revision)
@@ -3585,10 +3790,12 @@
 		   (let ((dst (if parent-1 older-char newer-char))
 			 (src (if parent-1 newer-char older-char)))
 		     (move-referenced-constructs src dst :revision revision)
+		     (delete-if-not-referenced src)
 		     dst))
 		  (t
 		   (move-referenced-constructs newer-char older-char
 					       :revision revision)
+		   (delete-if-not-referenced newer-char)
 		   older-char)))))))
 
 
@@ -3622,8 +3829,11 @@
 			       construct-1)))
 	  (unless (strictly-equivalent-constructs construct-1 construct-2
 						  :revision revision)
-	    (error "From merge-constructs(): ~a and ~a are not mergable"
-		   construct-1 construct-2))
+	    (error (make-condition 'not-mergable-error
+				   :message (format nil "From merge-constructs(): ~a and ~a are not mergable"
+						    construct-1 construct-2)
+				   :construct-1 construct-1
+				   :construct-2 construct-2)))
 	  (move-referenced-constructs newer-assoc older-assoc)
 	  (dolist (newer-role (roles newer-assoc :revision revision))
 	    (let ((equivalent-role
@@ -3652,8 +3862,11 @@
 			       construct-1)))
 	  (unless (strictly-equivalent-constructs construct-1 construct-2
 						  :revision revision)
-	    (error "From merge-constructs(): ~a and ~a are not mergable"
-		   construct-1 construct-2))
+	    (error (make-condition 'not-mergable-error
+				   :message (format nil "From merge-constructs(): ~a and ~a are not mergable"
+						    construct-1 construct-2)
+				   :construct-1 construct-1
+				   :construct-2 construct-2)))
 	  (let ((parent-1 (parent older-role :revision revision))
 		(parent-2 (parent newer-role :revision revision)))
 	    (cond ((and parent-1 (eql parent-1 parent-2))
@@ -3672,8 +3885,10 @@
 		   (let ((dst (if parent-1 older-role newer-role))
 			 (src (if parent-1 newer-role older-role)))
 		     (move-referenced-constructs src dst :revision revision)
+		     (delete-if-not-referenced src)
 		     dst))
 		  (t
 		   (move-referenced-constructs newer-role older-role
 					       :revision revision)
+		   (delete-if-not-referenced newer-role)
 		   older-role)))))))
\ No newline at end of file

Modified: branches/new-datamodel/src/model/exceptions.lisp
==============================================================================
--- branches/new-datamodel/src/model/exceptions.lisp	(original)
+++ branches/new-datamodel/src/model/exceptions.lisp	Thu Apr  8 05:55:12 2010
@@ -13,7 +13,10 @@
            :missing-reference-error
 	   :no-identifier-error
            :duplicate-identifier-error
-           :object-not-found-error))
+           :object-not-found-error
+	   :not-mergable-error
+	   :missing-argument-error
+	   :tm-reference-error))
 
 (in-package :exceptions)
 
@@ -22,6 +25,7 @@
     :initarg :message
     :accessor message)))
 
+
 (define-condition missing-reference-error(error)
   ((message
     :initarg :message
@@ -31,6 +35,7 @@
     :initarg :reference))
   (:documentation "thrown is a reference is missing"))
 
+
 (define-condition duplicate-identifier-error(error)
   ((message
     :initarg :message
@@ -40,12 +45,14 @@
     :initarg :reference))
   (:documentation "thrown if the same identifier is already in use"))
 
+
 (define-condition object-not-found-error(error)
   ((message
     :initarg :message
     :accessor message))
   (:documentation "thrown if the object could not be found"))
 
+
 (define-condition no-identifier-error(error)
   ((message
     :initarg :message
@@ -54,3 +61,48 @@
     :initarg :internal-id
     :accessor internal-id))
   (:documentation "thrown if the topic has no identifier"))
+
+
+(define-condition not-mergable-error (error)
+  ((message
+    :initarg :message
+    :accessor message)
+   (construc-1
+    :initarg :construct-1
+    :accessor construct-1)
+   (construc-2
+    :initarg :construct-2
+    :accessor construct-2))
+  (:documentation "Thrown if two constructs are not mergable since
+                   they have e.g. difference types."))
+
+
+(define-condition missing-argument-error (error)
+  ((message
+    :initarg :message
+    :accessor message)
+   (argument-symbol
+    :initarg :argument-symbol
+    :accessor argument-symbol)
+   (function-symbol
+    :initarg :function-symbol
+    :accessor function-symbol))
+  (:documentation "Thrown if a argument is missing in a function."))
+
+
+(define-condition tm-reference-error (error)
+  ((message
+    :initarg :message
+    :accessor message)
+   (referenced-construct
+    :initarg :referenced-construct
+    :accessor referenced-construct)
+   (existing-reference
+    :initarg :existing-reference
+    :accessor existing-reference)
+   (new-reference
+    :initarg :new-reference
+    :accessor new-reference))
+  (:documentation "Thrown of the referenced-construct is already owned by another
+                   TM-construct (existing-reference) and is going to be referenced
+                   by a second TM-construct (new-reference) at the same time."))
\ No newline at end of file

Modified: branches/new-datamodel/src/unit_tests/datamodel_test.lisp
==============================================================================
--- branches/new-datamodel/src/unit_tests/datamodel_test.lisp	(original)
+++ branches/new-datamodel/src/unit_tests/datamodel_test.lisp	Thu Apr  8 05:55:12 2010
@@ -15,7 +15,10 @@
    :fixtures
    :unittests-constants)
   (:import-from :exceptions
-		duplicate-identifier-error)
+		duplicate-identifier-error
+		missing-argument-error
+		tm-reference-error
+		object-not-found-error)
   (:import-from :constants
 		*xml-string*
 		*xml-uri*)
@@ -166,7 +169,7 @@
 	    (revision-4 400))
 	(setf d:*TM-REVISION* revision-1)
 	(is-false (identified-construct ii-1))
-	(signals error (make-instance 'ItemIdentifierC))
+	(signals missing-argument-error (make-instance 'ItemIdentifierC))
 	(is-false (item-identifiers topic-1))
 	(add-item-identifier topic-1 ii-1)
 	(is (= (length (d::versions topic-1)) 1))
@@ -232,7 +235,7 @@
 	    (revision-4 400))
 	(setf d:*TM-REVISION* revision-1)
 	(is-false (identified-construct psi-1))
-	(signals error (make-instance 'PersistentIdC))
+	(signals missing-argument-error (make-instance 'PersistentIdC))
 	(is-false (psis topic-1))
 	(add-psi topic-1 psi-1)
 	(is (= (length (d::versions topic-1)) 1))
@@ -296,7 +299,7 @@
 	    (revision-4 400))
 	(setf d:*TM-REVISION* revision-1)
 	(is-false (identified-construct sl-1))
-	(signals error (make-instance 'SubjectLocatorC))
+	(signals missing-argument-error (make-instance 'SubjectLocatorC))
 	(is-false (locators topic-1))
 	(add-locator topic-1 sl-1)
 	(is (= (length (d::versions topic-1)) 1))
@@ -362,9 +365,9 @@
 	    (revision-4 400))
 	(setf d:*TM-REVISION* revision-1)
 	(is-false (identified-construct ti-1))
-	(signals error (make-instance 'TopicIdentificationC
+	(signals missing-argument-error (make-instance 'TopicIdentificationC
 				      :uri "ti-1"))
-	(signals error (make-instance 'TopicIdentificationC
+	(signals missing-argument-error (make-instance 'TopicIdentificationC
 				      :xtm-id "xtm-id-1"))
 	(is-false (topic-identifiers topic-1))
 	(add-topic-identifier topic-1 ti-1)
@@ -436,11 +439,10 @@
 	    (rev-2 200))
 	(setf d:*TM-REVISION* rev-1)
 	(is-false (get-item-by-id "any-top-id" :revision rev-0))
-	(signals error (is-false (get-item-by-id
-				  "any-top-id" :xtm-id "any-xtm-id"
-				  :error-if-nil t)))
-	(signals error (is-false (get-item-by-id "any-top-id" :error-if-nil t
-						 :revision rev-0)))
+	(signals object-not-found-error
+	  (get-item-by-id "any-top-id" :xtm-id "any-xtm-id" :error-if-nil t))
+	(signals object-not-found-error
+	  (get-item-by-id "any-top-id" :error-if-nil t :revision rev-0))
 	(is-false (get-item-by-id "any-top-id" :xtm-id "any-xtm-id"))
 	(add-topic-identifier top-1 top-id-3-1 :revision rev-1)
 	(add-topic-identifier top-1 top-id-3-2 :revision rev-1)
@@ -497,12 +499,12 @@
 	    (rev-2 200))
 	(setf d:*TM-REVISION* rev-1)
 	(is-false (get-item-by-id "any-ii-id"))
-	(signals error (is-false (get-item-by-item-identifier
-				  "any-ii-id" :error-if-nil t
-				  :revision rev-1)))
-	(signals error (is-false (get-item-by-item-identifier
-				  "any-ii-id" :error-if-nil t
-				  :revision rev-1)))
+	(signals object-not-found-error
+	  (get-item-by-item-identifier
+	   "any-ii-id" :error-if-nil t :revision rev-1))
+	(signals object-not-found-error
+	  (get-item-by-item-identifier
+	   "any-ii-id" :error-if-nil t :revision rev-1))
 	(is-false (get-item-by-item-identifier "any-ii-id"))
 	(add-item-identifier top-1 ii-3-1 :revision rev-1)
 	(add-item-identifier top-1 ii-3-2 :revision rev-1)
@@ -542,12 +544,10 @@
 	    (rev-2 200))
 	(setf d:*TM-REVISION* rev-1)
 	(is-false (get-item-by-id "any-sl-id"))
-	(signals error (is-false (get-item-by-locator
-				  "any-sl-id" :error-if-nil t
-				  :revision rev-0)))
-	(signals error (is-false (get-item-by-locator
-				  "any-sl-id" :error-if-nil t
-				  :revision rev-0)))
+	(signals object-not-found-error
+	  (get-item-by-locator "any-sl-id" :error-if-nil t :revision rev-0))
+	(signals object-not-found-error
+	  (get-item-by-locator "any-sl-id" :error-if-nil t :revision rev-0))
 	(is-false (get-item-by-locator "any-sl-id" :revision rev-0))
 	(add-locator top-1 sl-3-1 :revision rev-1)
 	(add-locator top-1 sl-3-2 :revision rev-1)
@@ -587,12 +587,10 @@
 	    (rev-2 200))
 	(setf d:*TM-REVISION* rev-1)
 	(is-false (get-item-by-id "any-psi-id"))
-	(signals error (is-false (get-item-by-locator
-				  "any-psi-id" :error-if-nil t
-				   :revision rev-0)))
-	(signals error (is-false (get-item-by-locator
-				  "any-psi-id" :error-if-nil t
-				  :revision rev-0)))
+	(signals object-not-found-error
+	 (get-item-by-locator "any-psi-id" :error-if-nil t :revision rev-0))
+	(signals object-not-found-error
+	  (get-item-by-locator "any-psi-id" :error-if-nil t :revision rev-0))
 	(is-false (get-item-by-locator "any-psi-id"))
 	(add-psi top-1 psi-3-1 :revision rev-1)
 	(add-psi top-1 psi-3-2 :revision rev-1)
@@ -699,7 +697,7 @@
       (add-occurrence top-1 occ-1 :revision rev-4)
       (is (= (length (union (list occ-2 occ-1)
 			    (occurrences top-1 :revision rev-0))) 2))
-      (signals error (add-occurrence top-2 occ-1 :revision rev-4))
+      (signals tm-reference-error (add-occurrence top-2 occ-1 :revision rev-4))
       (delete-occurrence top-1 occ-1 :revision rev-5)
       (is (= (length (union (list occ-2)
 			    (occurrences top-1 :revision rev-5))) 1))
@@ -769,7 +767,7 @@
       (add-variant name-1 v-1 :revision rev-4)
       (is (= (length (union (list v-2 v-1)
 			    (variants name-1 :revision rev-0))) 2))
-      (signals error (add-variant name-2 v-1 :revision rev-4))
+      (signals tm-reference-error (add-variant name-2 v-1 :revision rev-4))
       (delete-variant name-1 v-1 :revision rev-5)
       (is (= (length (union (list v-2)
 			    (variants name-1 :revision rev-5))) 1))
@@ -844,7 +842,7 @@
       (add-name top-1 name-1 :revision rev-4)
       (is (= (length (union (list name-2 name-1)
 			    (names top-1 :revision rev-0))) 2))
-      (signals error (add-name top-2 name-1 :revision rev-4))
+      (signals tm-reference-error (add-name top-2 name-1 :revision rev-4))
       (delete-name top-1 name-1 :revision rev-5)
       (is (= (length (union (list name-2)
 			    (names top-1 :revision rev-5))) 1))
@@ -893,7 +891,7 @@
       (is (eql top-1 (instance-of name-1)))
       (is-false (instance-of name-1 :revision revision-0-5))
       (is (eql top-1 (instance-of name-1 :revision revision-2)))
-      (signals error (add-type name-1 top-2 :revision revision-0))
+      (signals tm-reference-error (add-type name-1 top-2 :revision revision-0))
       (add-type name-2 top-1 :revision revision-2)
       (is (= (length (union (list name-1 name-2)
 			    (used-as-type top-1 :revision revision-0))) 2))
@@ -998,7 +996,7 @@
       (is (eql (parent role-1 :revision rev-0) assoc-1))
       (is (eql (parent role-2 :revision rev-2) assoc-1))
       (is-false (parent role-2 :revision rev-1))
-      (signals error (add-parent role-2 assoc-2 :revision rev-2))
+      (signals tm-reference-error (add-parent role-2 assoc-2 :revision rev-2))
       (delete-role assoc-1 role-1 :revision rev-3)
       (is (= (length (d::versions assoc-1)) 3))
       (is-true (find-if #'(lambda(vi)
@@ -1056,7 +1054,7 @@
       (is (eql top-1 (player role-1 :revision revision-0)))
       (is-false (player role-1 :revision revision-0-5))
       (is (eql top-1 (player role-1 :revision revision-2)))
-      (signals error (add-player role-1 top-2))
+      (signals tm-reference-error (add-player role-1 top-2))
       (add-player role-2 top-1 :revision revision-2)
       (is (= (length (union (list role-1 role-2)
 			    (player-in-roles top-1 :revision revision-0))) 2))
@@ -2097,11 +2095,12 @@
 				       :start-revision rev-1
 				       :identifier psi-1
 				       :parent-construct top-1)))
-	(signals error (make-construct 'd::PersistentIdAssociationC
-				       :start-revision rev-1
-				       :identifier psi-1))
+	(signals missing-argument-error
+	  (make-construct 'd::PersistentIdAssociationC
+			  :start-revision rev-1
+			  :identifier psi-1))
 	(setf *TM-REVISION* rev-1)
-	(signals error (make-construct 'VersionedConstructC))
+	(signals missing-argument-error (make-construct 'VersionedConstructC))
 	(is (= (length (d::versions vc)) 1))
 	(is-true (find-if #'(lambda(vi)
 			      (and (= (d::start-revision vi) rev-2)
@@ -2127,13 +2126,14 @@
 				   :uri "tid-2" :xtm-id "xtm-id-2"
 				   :identified-construct top-1
 				   :start-revision rev-1)))
-	(signals error (make-construct 'TopicIdentificationC
+	(signals missing-argument-error (make-construct 'TopicIdentificationC
 				       :uri "uri"))
-	(signals error (make-construct 'TopicIdentificationC
+	(signals missing-argument-error (make-construct 'TopicIdentificationC
 				       :xtm-id "xtm-id"))
 	(setf *TM-REVISION* rev-1)
-	(signals error (make-construct 'TopicIdentificationC :uri "uri"
-				       :identified-construct top-1))
+	(signals missing-argument-error
+	  (make-construct 'TopicIdentificationC :uri "uri"
+			  :identified-construct top-1))
 	(is (string= (uri tid-1) "tid-1"))
 	(is (string= (xtm-id tid-1) "xtm-id-1"))
 	(is-false (d::slot-p tid-1 'd::identified-construct))
@@ -2168,8 +2168,8 @@
 				   :identified-construct top-1
 				   :start-revision rev-1)))
 	(setf *TM-REVISION* rev-1)
-	(signals error (make-construct 'PersistentIdC))
-	(signals error (make-construct 'PersistentIdC :uri "uri"
+	(signals missing-argument-error (make-construct 'PersistentIdC))
+	(signals missing-argument-error (make-construct 'PersistentIdC :uri "uri"
 				       :identified-construct top-1))
 	(is (string= (uri psi-1) "psi-1"))
 	(is-false (d::slot-p psi-1 'd::identified-construct))
@@ -2203,8 +2203,8 @@
 				  :identified-construct top-1
 				  :start-revision rev-1)))
 	(setf *TM-REVISION* rev-1)
-	(signals error (make-construct 'SubjectLocatorC))
-	(signals error (make-construct 'SubjectLocatorC :uri "uri"
+	(signals missing-argument-error (make-construct 'SubjectLocatorC))
+	(signals missing-argument-error (make-construct 'SubjectLocatorC :uri "uri"
 				       :identified-construct top-1))
 	(is (string= (uri sl-1) "sl-1"))
 	(is-false (d::slot-p sl-1 'd::identified-construct))
@@ -2238,8 +2238,8 @@
 				  :identified-construct top-1
 				  :start-revision rev-1)))
 	(setf *TM-REVISION* rev-1)
-	(signals error (make-construct 'ItemIdentifierC))
-	(signals error (make-construct 'ItemIdentifierC :uri "uri"
+	(signals missing-argument-error (make-construct 'ItemIdentifierC))
+	(signals missing-argument-error (make-construct 'ItemIdentifierC :uri "uri"
 				       :identified-construct top-1))
 	(is (string= (uri ii-1) "ii-1"))
 	(is-false (d::slot-p ii-1 'd::identified-construct))
@@ -2287,12 +2287,16 @@
 				   :parent top-1
 				   :start-revision rev-1)))
 	(setf *TM-REVISION* rev-1)
-	(signals error (make-construct 'OccurrenceC
-				       :item-identifiers (list ii-1)))
-	(signals error (make-construct 'OccurrenceC :reifier reifier-1))
-	(signals error (make-construct 'OccurrenceC :parent top-1))
-	(signals error (make-construct 'OccurrenceC :instance-of type-1))
-	(signals error (make-construct 'OccurrenceC :themes (list theme-1)))
+	(signals missing-argument-error
+	  (make-construct 'OccurrenceC :item-identifiers (list ii-1)))
+	(signals missing-argument-error
+	  (make-construct 'OccurrenceC :reifier reifier-1))
+	(signals missing-argument-error
+	  (make-construct 'OccurrenceC :parent top-1))
+	(signals missing-argument-error
+	  (make-construct 'OccurrenceC :instance-of type-1))
+	(signals missing-argument-error
+	  (make-construct 'OccurrenceC :themes (list theme-1)))
 	(is (string= (charvalue occ-1) ""))
 	(is (string= (datatype occ-1) *xml-string*))
 	(is-false (item-identifiers occ-1))
@@ -2344,13 +2348,18 @@
 				   :parent top-1
 				   :start-revision rev-1)))
 	(setf *TM-REVISION* rev-1)
-	(signals error (make-construct 'NameC
-				       :item-identifiers (list ii-1)))
-	(signals error (make-construct 'NameC :reifier reifier-1))
-	(signals error (make-construct 'NameC :parent top-1))
-	(signals error (make-construct 'NameC :instance-of type-1))
-	(signals error (make-construct 'NameC :themes (list theme-1)))
-	(signals error (make-construct 'NameC :variants (list variant-1)))
+	(signals missing-argument-error
+	  (make-construct 'NameC :item-identifiers (list ii-1)))
+	(signals missing-argument-error
+	  (make-construct 'NameC :reifier reifier-1))
+	(signals missing-argument-error
+	  (make-construct 'NameC :parent top-1))
+	(signals missing-argument-error
+	  (make-construct 'NameC :instance-of type-1))
+	(signals missing-argument-error
+	  (make-construct 'NameC :themes (list theme-1)))
+	(signals missing-argument-error
+	  (make-construct 'NameC :variants (list variant-1)))
 	(is (string= (charvalue name-1) ""))
 	(is-false (item-identifiers name-1))
 	(is-false (reifier name-1))
@@ -2399,11 +2408,14 @@
 				   :parent name-1
 				   :start-revision rev-1)))
 	(setf *TM-REVISION* rev-1)
-	(signals error (make-construct 'VariantC
-				       :item-identifiers (list ii-1)))
-	(signals error (make-construct 'VariantC :reifier reifier-1))
-	(signals error (make-construct 'VariantC :parent name-1))
-	(signals error (make-construct 'VariantC :themes (list theme-1)))
+	(signals missing-argument-error
+	  (make-construct 'VariantC :item-identifiers (list ii-1)))
+	(signals missing-argument-error
+	  (make-construct 'VariantC :reifier reifier-1))
+	(signals missing-argument-error
+	  (make-construct 'VariantC :parent name-1))
+	(signals missing-argument-error
+	  (make-construct 'VariantC :themes (list theme-1)))
 	(is (string= (charvalue variant-1) ""))
 	(is (string= (datatype variant-1) *xml-string*))
 	(is-false (item-identifiers variant-1))
@@ -2448,12 +2460,16 @@
 				   :parent assoc-1
 				   :start-revision rev-1)))
 	(setf *TM-REVISION* rev-1)
-	(signals error (make-construct 'RoleC
-				       :item-identifiers (list ii-1)))
-	(signals error (make-construct 'RoleC :reifier reifier-1))
-	(signals error (make-construct 'RoleC :parent assoc-1))
-	(signals error (make-construct 'RoleC :instance-of type-1))
-	(signals error (make-construct 'RoleC :player player-1))
+	(signals missing-argument-error
+	  (make-construct 'RoleC :item-identifiers (list ii-1)))
+	(signals missing-argument-error
+	  (make-construct 'RoleC :reifier reifier-1))
+	(signals missing-argument-error
+	  (make-construct 'RoleC :parent assoc-1))
+	(signals missing-argument-error
+	  (make-construct 'RoleC :instance-of type-1))
+	(signals missing-argument-error
+	  (make-construct 'RoleC :player player-1))
 	(is-false (item-identifiers role-1))
 	(is-false (reifier role-1))
 	(is-false (instance-of role-1))
@@ -2496,7 +2512,7 @@
 				  :start-revision rev-1
 				  :item-identifiers (list ii-3))))
 	(setf *TM-REVISION* rev-1)
-	(signals error (make-construct 'TopicMapC))
+	(signals missing-argument-error (make-construct 'TopicMapC))
 	(is (eql (reifier tm-1) reifier-1))
 	(is (= (length (item-identifiers tm-1)) 2))
 	(is (= (length (union (item-identifiers tm-1) (list ii-1 ii-2))) 2))
@@ -2566,12 +2582,12 @@
 				       :roles (list role-1 role-2 role-2-2)))
 	      (assoc-2 (make-construct 'AssociationC :start-revision rev-1)))
 	  (setf *TM-REVISION* rev-1)
-	  (signals error (make-construct 'AssociationC))
-	  (signals error (make-construct 'AssociationC
-					 :start-revision rev-1
-					 :roles (list
-						 (list :player player-1
-						       :instance-of r-type-1))))
+	  (signals missing-argument-error (make-construct 'AssociationC))
+	  (signals missing-argument-error
+	    (make-construct 'AssociationC
+			    :start-revision rev-1
+			    :roles (list (list :player player-1
+					       :instance-of r-type-1))))
 	  (is (eql (instance-of assoc-1) type-1))
 	  (is-true (themes assoc-1))
 	  (is (= (length (union (list theme-1 theme-2) (themes assoc-1))) 2))
@@ -2684,7 +2700,7 @@
 				     :names (list name-1)
 				     :occurrences (list occ-1))))
 	  (setf *TM-REVISION* rev-1)
-	  (signals error (make-construct 'TopicC))
+	  (signals missing-argument-error (make-construct 'TopicC))
 	  (is-false (item-identifiers top-1))
 	  (is-false (psis top-1))
 	  (is-false (locators top-1))




More information about the Isidorus-cvs mailing list