[isidorus-cvs] r246 - in branches/new-datamodel/src: model unit_tests
Lukas Giessmann
lgiessmann at common-lisp.net
Mon Mar 22 18:14:02 UTC 2010
Author: lgiessmann
Date: Mon Mar 22 14:14:02 2010
New Revision: 246
Log:
replaced all keyword parameters of the form "(revision 0)" or "(start-revision 0)" to "(revision *TM-REVISION*)" and "(start-revision *TM-REVISION*)" to be compatible with the macro "with-revision" which uses the variable "*TM-REVISION*"
Modified:
branches/new-datamodel/src/model/datamodel.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 Mon Mar 22 14:14:02 2010
@@ -156,9 +156,6 @@
-;;TOOD: replace the key argument (revision 0)/(start-revision 0)
-;; by (start-revision *TM-REVISION*) (revision *TM-REVISION*)
-;; to be compatible to the macro with-revision
;;TODO: check merge-constructs in add-topic-identifier,
;; add-item-identifier/add-reifier (can merge the parent constructs
;; and the parent's parent construct + the reifier constructs),
@@ -765,7 +762,7 @@
its parent-construct."))
-(defgeneric check-for-duplicate-identifiers (construct)
+(defgeneric check-for-duplicate-identifiers (construct &key revision)
(:documentation "Check for possibly duplicate identifiers and signal an
duplicate-identifier-error is such duplicates are found"))
@@ -926,8 +923,9 @@
;;; TopicMapconstructC
-(defmethod check-for-duplicate-identifiers ((construct TopicMapConstructC))
- (declare (ignore construct))
+(defmethod check-for-duplicate-identifiers ((construct TopicMapConstructC)
+ &key revision)
+ (declare (ignorable revision construct))
;do nothing
)
@@ -1009,7 +1007,7 @@
(defgeneric identified-construct (construct &key revision)
(:documentation "Returns the identified-construct -> ReifiableConstructC or
TopicC that corresponds with the passed revision.")
- (:method ((construct PointerC) &key (revision 0))
+ (:method ((construct PointerC) &key (revision *TM-REVISION*))
(let ((assocs
(map 'list #'parent-construct
(filter-slot-value-by-revision construct 'identified-construct
@@ -1218,7 +1216,7 @@
(= essentially the OID). If xtm-id is explicitly given,
returns one of the topic-ids in that TM
(which must then exist).")
- (:method ((construct TopicC) &optional (xtm-id nil) (revision 0))
+ (:method ((construct TopicC) &optional (xtm-id nil) (revision *TM-REVISION*))
(declare (type (or null string) xtm-id) (integer revision))
(if xtm-id
(let ((possible-identifiers
@@ -1240,7 +1238,7 @@
(defgeneric topic-identifiers (construct &key revision)
(:documentation "Returns the TopicIdentificationC-objects that correspond
with the passed construct and the passed version.")
- (:method ((construct TopicC) &key (revision 0))
+ (:method ((construct TopicC) &key (revision *TM-REVISION*))
(let ((assocs (filter-slot-value-by-revision
construct 'topic-identifiers :start-revision revision)))
(map 'list #'identifier assocs))))
@@ -1257,7 +1255,8 @@
(let ((all-ids
(map 'list #'identifier (slot-p construct 'topic-identifiers)))
(construct-to-be-merged
- (let ((id-owner (identified-construct topic-identifier)))
+ (let ((id-owner (identified-construct topic-identifier
+ :revision revision)))
(when (not (eql id-owner construct))
id-owner))))
(let ((merged-construct construct))
@@ -1298,7 +1297,7 @@
(defgeneric psis (construct &key revision)
(:documentation "Returns the PersistentIdC-objects that correspond
with the passed construct and the passed version.")
- (:method ((construct TopicC) &key (revision 0))
+ (:method ((construct TopicC) &key (revision *TM-REVISION*))
(let ((assocs (filter-slot-value-by-revision
construct 'psis :start-revision revision)))
(map 'list #'identifier assocs))))
@@ -1315,7 +1314,7 @@
(let ((all-ids
(map 'list #'identifier (slot-p construct 'psis)))
(construct-to-be-merged
- (let ((id-owner (identified-construct psi)))
+ (let ((id-owner (identified-construct psi :revision revision)))
(when (not (eql id-owner construct))
id-owner))))
(let ((merged-construct construct))
@@ -1354,7 +1353,7 @@
(defgeneric locators (construct &key revision)
(:documentation "Returns the SubjectLocatorC-objects that correspond
with the passed construct and the passed version.")
- (:method ((construct TopicC) &key (revision 0))
+ (:method ((construct TopicC) &key (revision *TM-REVISION*))
(let ((assocs (filter-slot-value-by-revision
construct 'locators :start-revision revision)))
(map 'list #'identifier assocs))))
@@ -1371,7 +1370,7 @@
(let ((all-ids
(map 'list #'identifier (slot-p construct 'locators)))
(construct-to-be-merged
- (let ((id-owner (identified-construct locator)))
+ (let ((id-owner (identified-construct locator :revision revision)))
(when (not (eql id-owner construct))
id-owner))))
(let ((merged-construct construct))
@@ -1409,7 +1408,7 @@
(defmethod get-all-identifiers-of-construct ((construct TopicC)
- &key (revision 0))
+ &key (revision *TM-REVISION*))
(declare (integer revision))
(append (psis construct :revision revision)
(locators construct :revision revision)
@@ -1419,7 +1418,7 @@
(defgeneric names (construct &key revision)
(:documentation "Returns the NameC-objects that correspond
with the passed construct and the passed version.")
- (:method ((construct TopicC) &key (revision 0))
+ (:method ((construct TopicC) &key (revision *TM-REVISION*))
(let ((assocs (filter-slot-value-by-revision
construct 'names :start-revision revision)))
(map 'list #'characteristic assocs))))
@@ -1470,7 +1469,7 @@
(defgeneric occurrences (construct &key revision)
(:documentation "Returns the OccurrenceC-objects that correspond
with the passed construct and the passed version.")
- (:method ((construct TopicC) &key (revision 0))
+ (:method ((construct TopicC) &key (revision *TM-REVISION*))
(let ((assocs (filter-slot-value-by-revision
construct 'occurrences :start-revision revision)))
(map 'list #'characteristic assocs))))
@@ -1485,9 +1484,9 @@
(:method ((construct TopicC) (occurrence OccurrenceC)
&key (revision *TM-REVISION*))
(when (and (parent occurrence :revision revision)
- (not (eql (parent occurrence) construct)))
+ (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)))
+ occurrence construct (parent occurrence :revision revision)))
(let ((all-occurrences
(map 'list #'characteristic (slot-p construct 'occurrences))))
(if (find occurrence all-occurrences)
@@ -1520,7 +1519,7 @@
(defgeneric player-in-roles (construct &key revision)
(:documentation "Returns the RoleC-objects that correspond
with the passed construct and the passed version.")
- (:method ((construct TopicC) &key (revision 0))
+ (:method ((construct TopicC) &key (revision *TM-REVISION*))
(let ((assocs (filter-slot-value-by-revision
construct 'player-in-roles :start-revision revision)))
(map 'list #'parent-construct assocs))))
@@ -1529,7 +1528,7 @@
(defgeneric used-as-type (construct &key revision)
(:documentation "Returns the TypableC-objects that correspond
with the passed construct and the passed version.")
- (:method ((construct TopicC) &key (revision 0))
+ (:method ((construct TopicC) &key (revision *TM-REVISION*))
(let ((assocs (filter-slot-value-by-revision
construct 'used-as-type :start-revision revision)))
(map 'list #'typable-construct assocs))))
@@ -1538,7 +1537,7 @@
(defgeneric used-as-theme (construct &key revision)
(:documentation "Returns the ScopableC-objects that correspond
with the passed construct and the passed version.")
- (:method ((construct TopicC) &key (revision 0))
+ (:method ((construct TopicC) &key (revision *TM-REVISION*))
(let ((assocs (filter-slot-value-by-revision
construct 'used-as-theme :start-revision revision)))
(map 'list #'scopable-construct assocs))))
@@ -1547,18 +1546,19 @@
(defgeneric reified-construct (construct &key revision)
(:documentation "Returns the ReifiableConstructC-objects that correspond
with the passed construct and the passed version.")
- (:method ((construct TopicC) &key (revision 0))
+ (:method ((construct TopicC) &key (revision *TM-REVISION*))
(let ((assocs (filter-slot-value-by-revision
construct 'reified-construct :start-revision revision)))
(when assocs
(reifiable-construct (first assocs))))))
-(defmethod in-topicmaps ((topic TopicC) &key (revision 0))
+(defmethod in-topicmaps ((topic TopicC) &key (revision *TM-REVISION*))
(filter-slot-value-by-revision topic 'in-topicmaps :start-revision revision))
-(defun get-item-by-id (topic-id &key (xtm-id *CURRENT-XTM*) (revision 0) (error-if-nil nil))
+(defun get-item-by-id (topic-id &key (xtm-id *CURRENT-XTM*)
+ (revision *TM-REVISION*) (error-if-nil nil))
"Gets a topic by its id, assuming an xtm-id. If xtm-id is empty, the current TM
is chosen. If xtm-id is nil, choose the global TM with its internal ID, if
applicable in the correct revision. If revison is provided, then the code checks
@@ -1580,7 +1580,8 @@
'uri
topic-id))))
(when (and possible-top-ids
- (identified-construct (first possible-top-ids) :revision revision))
+ (identified-construct (first possible-top-ids)
+ :revision revision))
(unless (= (length possible-top-ids) 1)
(error
(make-condition 'duplicate-identifier-error
@@ -1606,7 +1607,7 @@
result)))
-(defun get-item-by-identifier (uri &key (revision 0)
+(defun get-item-by-identifier (uri &key (revision *TM-REVISION*)
(identifier-type-symbol 'PersistentIdC)
(error-if-nil nil))
"Returns the construct that is bound to the given identifier-uri."
@@ -1618,7 +1619,8 @@
(string= (uri id) uri))
(get-instances-by-value identifier-type-symbol 'uri uri))))
(when (and possible-ids
- (identified-construct (first possible-ids) :revision revision))
+ (identified-construct (first possible-ids)
+ :revision revision))
(unless (= (length possible-ids) 1)
(error (make-condition 'duplicate-identifier-error
:message (format nil "(length possible-items ~a) for id ~a"
@@ -1634,21 +1636,22 @@
(error "No such item is bound to the given identifier uri.")))))
-(defun get-item-by-item-identifier (uri &key (revision 0) (error-if-nil nil))
+(defun get-item-by-item-identifier (uri &key (revision *TM-REVISION*)
+ (error-if-nil nil))
"Returns a ReifiableConstructC that is bound to the identifier-uri."
(get-item-by-identifier uri :revision revision
:identifier-type-symbol 'ItemIdentifierC
:error-if-nil error-if-nil))
-(defun get-item-by-psi (uri &key (revision 0) (error-if-nil nil))
+(defun get-item-by-psi (uri &key (revision *TM-REVISION*) (error-if-nil nil))
"Returns a TopicC that is bound to the identifier-uri."
(get-item-by-identifier uri :revision revision
:identifier-type-symbol 'PersistentIdC
:error-if-nil error-if-nil))
-(defun get-item-by-locator (uri &key (revision 0) (error-if-nil nil))
+(defun get-item-by-locator (uri &key (revision *TM-REVISION*) (error-if-nil nil))
"Returns a TopicC that is bound to the identifier-uri."
(get-item-by-identifier uri :revision revision
:identifier-type-symbol 'SubjectLocatorC
@@ -1658,7 +1661,7 @@
(defgeneric list-instanceOf (topic &key tm revision)
(:documentation "Generates a list of all topics that this topic is an
instance of, optionally filtered by a topic map")
- (:method ((topic TopicC) &key (tm nil) (revision 0))
+ (:method ((topic TopicC) &key (tm nil) (revision *TM-REVISION*))
(declare (type (or null TopicMapC) tm)
(integer revision))
(remove-if
@@ -1676,7 +1679,8 @@
(if tm
(remove-if-not
(lambda (role)
- (in-topicmap tm (parent role :revision revision)))
+ (in-topicmap tm (parent role :revision revision)
+ :revision revision))
(player-in-roles topic :revision revision))
(player-in-roles topic :revision revision))))))
@@ -1684,7 +1688,7 @@
(defgeneric list-super-types (topic &key tm revision)
(:documentation "Generate a list of all topics that this topic is an
subclass of, optionally filtered by a topic map")
- (:method ((topic TopicC) &key (tm nil) (revision 0))
+ (:method ((topic TopicC) &key (tm nil) (revision *TM-REVISION*))
(declare (type (or null TopicMapC) tm)
(integer revision))
(remove-if
@@ -1702,7 +1706,8 @@
(if tm
(remove-if-not
(lambda (role)
- (in-topicmap tm (parent role :revision revision)))
+ (in-topicmap tm (parent role :revision revision)
+ :revision revision))
(player-in-roles topic :revision revision))
(player-in-roles topic :revision revision))))))
@@ -1719,8 +1724,8 @@
(defmethod equivalent-construct ((construct CharacteristicC)
- &key (start-revision 0) (charvalue "")
- (instance-of nil) (themes nil))
+ &key (start-revision *TM-REVISION*)
+ (charvalue "") (instance-of nil) (themes nil))
"Equality rule: Characteristics are equal if charvalue, themes and
instance-of are equal."
(declare (string charvalue) (list themes)
@@ -1778,7 +1783,7 @@
(:documentation "Returns the parent construct of the passed object that
corresponds with the given revision. The returned construct
can be a TopicC or a NameC.")
- (:method ((construct CharacteristicC) &key (revision 0))
+ (:method ((construct CharacteristicC) &key (revision *TM-REVISION*))
(let ((valid-associations
(filter-slot-value-by-revision construct 'parent
:start-revision revision)))
@@ -1845,15 +1850,15 @@
(defmethod equivalent-construct ((construct OccurrenceC)
- &key (start-revision 0) (charvalue "")
- (themes nil) (instance-of nil)
+ &key (start-revision *TM-REVISION*)
+ (charvalue "") (themes nil) (instance-of nil)
(datatype ""))
"Occurrences are equal if their charvalue, datatype, themes and
instance-of properties are equal."
(declare (type (or null TopicC) instance-of) (string datatype)
(ignorable start-revision charvalue themes instance-of))
(let ((equivalent-characteristic (call-next-method)))
- ;; item-identifiers and reifers are not checked because the equality have to
+ ;; item-identifiers and reifers are not checked because the equaity have to
;; be variafied without them
(and equivalent-characteristic
(string= (datatype construct) datatype))))
@@ -1867,8 +1872,8 @@
(defmethod equivalent-construct ((construct VariantC)
- &key (start-revision 0) (charvalue "")
- (themes nil) (datatype ""))
+ &key (start-revision *TM-REVISION*)
+ (charvalue "") (themes nil) (datatype ""))
"Variants are equal if their charvalue, datatype and themes
properties are equal."
(declare (string datatype) (ignorable start-revision charvalue themes))
@@ -1902,8 +1907,8 @@
(defmethod equivalent-construct ((construct NameC)
- &key (start-revision 0) (charvalue "")
- (themes nil) (instance-of nil))
+ &key (start-revision *TM-REVISION*)
+ (charvalue "") (themes nil) (instance-of nil))
"Names are equal if their charvalue, instance-of and themes properties
are equal."
(declare (type (or null TopicC) instance-of)
@@ -1924,7 +1929,7 @@
(defgeneric variants (construct &key revision)
(:documentation "Returns all variants that correspond with the given revision
and that are associated with the passed construct.")
- (:method ((construct NameC) &key (revision 0))
+ (:method ((construct NameC) &key (revision *TM-REVISION*))
(let ((valid-associations
(filter-slot-value-by-revision construct 'variants
:start-revision revision)))
@@ -1939,7 +1944,7 @@
(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)))
+ variant construct (parent variant :revision revision)))
(let ((all-variants
(map 'list #'characteristic (slot-p construct 'variants))))
(if (find variant all-variants)
@@ -1977,8 +1982,8 @@
(defmethod equivalent-construct ((construct AssociationC)
- &key (start-revision 0) (roles nil)
- (instance-of nil) (themes nil))
+ &key (start-revision *TM-REVISION*)
+ (roles nil) (instance-of nil) (themes nil))
"Associations are equal if their themes, instance-of and roles
properties are equal."
(declare (integer start-revision) (list roles themes)
@@ -2013,7 +2018,7 @@
(defgeneric roles (construct &key revision)
(:documentation "Returns all topics that correspond with the given revision
as a scope for the given topic.")
- (:method ((construct AssociationC) &key (revision 0))
+ (:method ((construct AssociationC) &key (revision *TM-REVISION*))
(let ((valid-associations
(filter-slot-value-by-revision construct 'roles
:start-revision revision)))
@@ -2054,7 +2059,7 @@
construct)))
-(defmethod in-topicmaps ((association AssociationC) &key (revision 0))
+(defmethod in-topicmaps ((association AssociationC) &key (revision *TM-REVISION*))
(filter-slot-value-by-revision association 'in-topicmaps :start-revision revision))
@@ -2066,8 +2071,8 @@
(defmethod equivalent-construct ((construct RoleC)
- &key (start-revision 0) (player nil)
- (instance-of nil))
+ &key (start-revision *TM-REVISION*)
+ (player nil) (instance-of nil))
"Roles are equal if their instance-of and player properties are equal."
(declare (integer start-revision) (type (or null TopicC) player instance-of))
;; item-identifiers and reifers are not checked because the equality have to
@@ -2124,7 +2129,7 @@
t))
-(defmethod parent ((construct RoleC) &key (revision 0))
+(defmethod parent ((construct RoleC) &key (revision *TM-REVISION*))
"Returns the construct's parent corresponding to the given revision."
(let ((valid-associations
(filter-slot-value-by-revision construct 'parent
@@ -2176,7 +2181,7 @@
(defgeneric player (construct &key revision)
(:documentation "Returns the construct's player corresponding to
the given revision.")
- (:method ((construct RoleC) &key (revision 0))
+ (:method ((construct RoleC) &key (revision *TM-REVISION*))
(let ((valid-associations
(filter-slot-value-by-revision construct 'player
:start-revision revision)))
@@ -2228,8 +2233,10 @@
;;; ReifiableConstructC
-(defmethod check-for-duplicate-identifiers ((construct ReifiableConstructC))
- (dolist (id (get-all-identifiers-of-construct construct))
+(defmethod check-for-duplicate-identifiers ((construct ReifiableConstructC)
+ &key (revision *TM-REVISION*))
+ (declare (integer revision))
+ (dolist (id (get-all-identifiers-of-construct construct :revision revision))
(when (>
(length
(union
@@ -2281,7 +2288,7 @@
the reifiable construct have to share an item identifier
or reifier.")
(:method ((construct ReifiableConstructC) reifier item-identifiers
- &key (start-revision 0))
+ &key (start-revision *TM-REVISION*))
(declare (integer start-revision) (list item-identifiers)
(type (or null TopicC) reifier))
(or (and (reifier construct :revision start-revision)
@@ -2306,7 +2313,7 @@
(defgeneric item-identifiers (construct &key revision)
(:documentation "Returns the ItemIdentifierC-objects that correspond
with the passed construct and the passed version.")
- (:method ((construct ReifiableConstructC) &key (revision 0))
+ (:method ((construct ReifiableConstructC) &key (revision *TM-REVISION*))
(let ((assocs (filter-slot-value-by-revision
construct 'item-identifiers :start-revision revision)))
(map 'list #'identifier assocs))))
@@ -2315,7 +2322,7 @@
(defgeneric reifier (construct &key revision)
(:documentation "Returns the reifier-topic that corresponds
with the passed construct and the passed version.")
- (:method ((construct ReifiableConstructC) &key (revision 0))
+ (:method ((construct ReifiableConstructC) &key (revision *TM-REVISION*))
(let ((assocs (filter-slot-value-by-revision
construct 'reifier :start-revision revision)))
(when assocs ;assocs must be nil or a list with exactly one item
@@ -2333,7 +2340,8 @@
(let ((all-ids
(map 'list #'identifier (slot-p construct 'item-identifiers)))
(construct-to-be-merged
- (let ((id-owner (identified-construct item-identifier)))
+ (let ((id-owner (identified-construct item-identifier
+ :revision revision)))
(when (not (eql id-owner construct))
id-owner))))
(let ((merged-construct construct))
@@ -2381,8 +2389,9 @@
(:method ((construct ReifiableConstructC) (reifier-topic TopicC)
&key (revision *TM-REVISION*))
(let ((merged-reifier-topic
- (if (reifier construct)
- (merge-constructs (reifier construct) reifier-topic)
+ (if (reifier construct :revision revision)
+ (merge-constructs (reifier construct :revision revision)
+ reifier-topic)
reifier-topic)))
(let ((all-constructs
(let ((inner-construct (reified-construct merged-reifier-topic
@@ -2427,7 +2436,7 @@
(defmethod get-all-identifiers-of-construct ((construct ReifiableConstructC)
- &key (revision 0))
+ &key (revision *TM-REVISION*))
(declare (integer revision))
(item-identifiers construct :revision revision))
@@ -2457,7 +2466,7 @@
&key start-revision)
(:documentation "Returns t if the passed constructs are TMDM equal, i.e.
the typable constructs have to own the same type.")
- (:method ((construct TypableC) instance-of &key (start-revision 0))
+ (:method ((construct TypableC) instance-of &key (start-revision *TM-REVISION*))
(declare (integer start-revision)
(type (or null TopicC) instance-of))
(eql (instance-of construct :revision start-revision) instance-of)))
@@ -2486,7 +2495,7 @@
(defgeneric equivalent-scopable-construct (construct themes &key start-revision)
(:documentation "Returns t if the passed constructs are TMDM equal, i.e.
the scopable constructs have to own the same themes.")
- (:method ((construct ScopableC) themes &key (start-revision 0))
+ (:method ((construct ScopableC) themes &key (start-revision *TM-REVISION*))
(declare (integer start-revision) (list themes))
(not (set-exclusive-or (themes construct :revision start-revision)
themes))))
@@ -2500,7 +2509,7 @@
(defgeneric themes (construct &key revision)
(:documentation "Returns all topics that correspond with the given revision
as a scope for the given topic.")
- (:method ((construct ScopableC) &key (revision 0))
+ (:method ((construct ScopableC) &key (revision *TM-REVISION*))
(let ((valid-associations
(filter-slot-value-by-revision construct 'themes
:start-revision revision)))
@@ -2561,7 +2570,7 @@
(defgeneric instance-of (construct &key revision)
(:documentation "Returns the type topic that is set on the passed
revision.")
- (:method ((construct TypableC) &key (revision 0))
+ (:method ((construct TypableC) &key (revision *TM-REVISION*))
(let ((valid-associations
(filter-slot-value-by-revision construct 'instance-of
:start-revision revision)))
@@ -2626,8 +2635,8 @@
(defmethod equivalent-construct ((construct TopicMapC)
- &key (start-revision 0) (reifier nil)
- (item-identifiers nil))
+ &key (start-revision *TM-REVISION*)
+ (reifier nil) (item-identifiers nil))
"TopicMaps equality if they share the same item-identier or reifier."
(declare (list item-identifiers) (integer start-revision)
(type (or null TopicC) reifier))
@@ -2664,12 +2673,14 @@
topic map?"))
-(defmethod in-topicmap ((tm TopicMapC) (top TopicC) &key (revision 0))
+(defmethod in-topicmap ((tm TopicMapC) (top TopicC) &key
+ (revision *TM-REVISION*))
(when (find-item-by-revision top revision)
(find (internal-id top) (topics tm) :test #'= :key #'internal-id)))
-(defmethod in-topicmap ((tm TopicMapC) (ass AssociationC) &key (revision 0))
+(defmethod in-topicmap ((tm TopicMapC) (ass AssociationC)
+ &key (revision *TM-REVISION*))
(when (find-item-by-revision ass revision)
(find (internal-id ass) (associations tm) :test #'= :key #'internal-id)))
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 Mon Mar 22 14:14:02 2010
@@ -417,44 +417,51 @@
(top-1 (make-instance 'TopicC))
(top-2 (make-instance 'TopicC))
(top-3 (make-instance 'TopicC))
- (revision 100)
- (revision-2 200))
- (setf d:*TM-REVISION* revision)
- (is-false (get-item-by-id "any-top-id"))
+ (rev-0 0)
+ (rev-1 100)
+ (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)))
+ (signals error (is-false (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 revision)
- (add-topic-identifier top-1 top-id-3-2 :revision revision)
+ (add-topic-identifier top-1 top-id-3-1 :revision rev-1)
+ (add-topic-identifier top-1 top-id-3-2 :revision rev-1)
(signals duplicate-identifier-error
- (get-item-by-id "topid-3" :xtm-id "xtm-id-3" :revision revision))
+ (get-item-by-id "topid-3" :xtm-id "xtm-id-3" :revision rev-1))
(add-topic-identifier top-2 top-id-1)
- (add-topic-identifier top-2 top-id-2 :revision revision-2)
- (is (eql top-2 (get-item-by-id "topid-1" :xtm-id "xtm-id-1")))
- (is (eql top-2 (get-item-by-id "topid-2" :xtm-id "xtm-id-2")))
+ (add-topic-identifier top-2 top-id-2 :revision rev-2)
+ (is (eql top-2 (get-item-by-id "topid-1" :xtm-id "xtm-id-1"
+ :revision rev-0)))
+ (is (eql top-2 (get-item-by-id "topid-2" :xtm-id "xtm-id-2"
+ :revision rev-0)))
(is (eql top-2 (get-item-by-id "topid-1" :xtm-id "xtm-id-1"
:revision 500)))
(is-false (get-item-by-id "topid-2" :xtm-id "xtm-id-2"
- :revision revision))
- (delete-topic-identifier top-2 top-id-1 :revision revision-2)
- (is-false (get-item-by-id "topid-1" :xtm-id "xtm-id-1"))
+ :revision rev-1))
+ (delete-topic-identifier top-2 top-id-1 :revision rev-2)
+ (is-false (get-item-by-id "topid-1" :xtm-id "xtm-id-1"
+ :revision rev-0))
(is (eql top-2 (get-item-by-id "topid-1" :xtm-id "xtm-id-1"
- :revision revision)))
- (add-topic-identifier top-3 top-id-1 :revision revision-2)
+ :revision rev-1)))
+ (add-topic-identifier top-3 top-id-1 :revision rev-2)
(is (eql top-2 (get-item-by-id "topid-1" :xtm-id "xtm-id-1"
- :revision revision)))
- (d::add-to-version-history top-3 :start-revision revision-2)
- (is (eql top-3 (get-item-by-id "topid-1" :xtm-id "xtm-id-1")))
+ :revision rev-1)))
+ (d::add-to-version-history top-3 :start-revision rev-2)
+ (is (eql top-3 (get-item-by-id "topid-1" :xtm-id "xtm-id-1"
+ :revision rev-0)))
(is (eql top-3
(get-item-by-id
(concatenate 'string "t" (write-to-string
- (elephant::oid top-3))))))
+ (elephant::oid top-3)))
+ :revision rev-0)))
(is-false (get-item-by-id
(concatenate 'string "t" (write-to-string
(elephant::oid top-3)))
- :revision revision)))))
+ :revision rev-1)))))
(test test-get-item-by-item-identifier ()
@@ -471,32 +478,35 @@
(top-1 (make-instance 'TopicC))
(top-2 (make-instance 'TopicC))
(top-3 (make-instance 'TopicC))
- (revision 100)
- (revision-2 200))
- (setf d:*TM-REVISION* revision)
+ (rev-0 0)
+ (rev-1 100)
+ (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)))
+ "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)))
+ "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 revision)
- (add-item-identifier top-1 ii-3-2 :revision revision)
+ (add-item-identifier top-1 ii-3-1 :revision rev-1)
+ (add-item-identifier top-1 ii-3-2 :revision rev-1)
(signals duplicate-identifier-error
- (get-item-by-item-identifier "ii-3" :revision revision))
+ (get-item-by-item-identifier "ii-3" :revision rev-1))
(add-item-identifier top-2 ii-1)
- (add-item-identifier top-2 ii-2 :revision revision-2)
- (is (eql top-2 (get-item-by-item-identifier "ii-1")))
- (is (eql top-2 (get-item-by-item-identifier "ii-2")))
+ (add-item-identifier top-2 ii-2 :revision rev-2)
+ (is (eql top-2 (get-item-by-item-identifier "ii-1" :revision rev-0)))
+ (is (eql top-2 (get-item-by-item-identifier "ii-2" :revision rev-0)))
(is (eql top-2 (get-item-by-item-identifier "ii-1" :revision 500)))
- (is-false (get-item-by-item-identifier "ii-2" :revision revision))
- (delete-item-identifier top-2 ii-1 :revision revision-2)
- (is-false (get-item-by-item-identifier "ii-1"))
- (is (eql top-2 (get-item-by-item-identifier "ii-1" :revision revision)))
- (add-item-identifier top-3 ii-1 :revision revision-2)
- (is (eql top-2 (get-item-by-item-identifier "ii-1" :revision revision)))
- (d::add-to-version-history top-3 :start-revision revision-2)
- (is (eql top-3 (get-item-by-item-identifier "ii-1"))))))
+ (is-false (get-item-by-item-identifier "ii-2" :revision rev-1))
+ (delete-item-identifier top-2 ii-1 :revision rev-2)
+ (is-false (get-item-by-item-identifier "ii-1" :revision rev-0))
+ (is (eql top-2 (get-item-by-item-identifier "ii-1" :revision rev-1)))
+ (add-item-identifier top-3 ii-1 :revision rev-2)
+ (is (eql top-2 (get-item-by-item-identifier "ii-1" :revision rev-1)))
+ (d::add-to-version-history top-3 :start-revision rev-2)
+ (is (eql top-3 (get-item-by-item-identifier "ii-1" :revision rev-0))))))
(test test-get-item-by-locator ()
@@ -513,32 +523,35 @@
(top-1 (make-instance 'TopicC))
(top-2 (make-instance 'TopicC))
(top-3 (make-instance 'TopicC))
- (revision 100)
- (revision-2 200))
- (setf d:*TM-REVISION* revision)
+ (rev-0 0)
+ (rev-1 100)
+ (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)))
+ "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)))
- (is-false (get-item-by-locator "any-sl-id"))
- (add-locator top-1 sl-3-1 :revision revision)
- (add-locator top-1 sl-3-2 :revision revision)
+ "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)
(signals duplicate-identifier-error
- (get-item-by-locator "sl-3" :revision revision))
+ (get-item-by-locator "sl-3" :revision rev-1))
(add-locator top-2 sl-1)
- (add-locator top-2 sl-2 :revision revision-2)
- (is (eql top-2 (get-item-by-locator "sl-1")))
- (is (eql top-2 (get-item-by-locator "sl-2")))
+ (add-locator top-2 sl-2 :revision rev-2)
+ (is (eql top-2 (get-item-by-locator "sl-1" :revision rev-0)))
+ (is (eql top-2 (get-item-by-locator "sl-2" :revision rev-0)))
(is (eql top-2 (get-item-by-locator "sl-1" :revision 500)))
- (is-false (get-item-by-locator "sl-2" :revision revision))
- (delete-locator top-2 sl-1 :revision revision-2)
- (is-false (get-item-by-locator "sl-1"))
- (is (eql top-2 (get-item-by-locator "sl-1" :revision revision)))
- (add-locator top-3 sl-1 :revision revision-2)
- (is (eql top-2 (get-item-by-locator "sl-1" :revision revision)))
- (d::add-to-version-history top-3 :start-revision revision-2)
- (is (eql top-3 (get-item-by-locator "sl-1"))))))
+ (is-false (get-item-by-locator "sl-2" :revision rev-1))
+ (delete-locator top-2 sl-1 :revision rev-2)
+ (is-false (get-item-by-locator "sl-1" :revision rev-0))
+ (is (eql top-2 (get-item-by-locator "sl-1" :revision rev-1)))
+ (add-locator top-3 sl-1 :revision rev-2)
+ (is (eql top-2 (get-item-by-locator "sl-1" :revision rev-1)))
+ (d::add-to-version-history top-3 :start-revision rev-2)
+ (is (eql top-3 (get-item-by-locator "sl-1" :revision rev-0))))))
(test test-get-item-by-psi ()
@@ -555,32 +568,35 @@
(top-1 (make-instance 'TopicC))
(top-2 (make-instance 'TopicC))
(top-3 (make-instance 'TopicC))
- (revision 100)
- (revision-2 200))
- (setf d:*TM-REVISION* revision)
+ (rev-0 0)
+ (rev-1 100)
+ (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)))
+ "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)))
+ "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 revision)
- (add-psi top-1 psi-3-2 :revision revision)
+ (add-psi top-1 psi-3-1 :revision rev-1)
+ (add-psi top-1 psi-3-2 :revision rev-1)
(signals duplicate-identifier-error
- (get-item-by-locator "psi-3" :revision revision))
+ (get-item-by-locator "psi-3" :revision rev-1))
(add-psi top-2 psi-1)
- (add-psi top-2 psi-2 :revision revision-2)
- (is (eql top-2 (get-item-by-locator "psi-1")))
- (is (eql top-2 (get-item-by-locator "psi-2")))
+ (add-psi top-2 psi-2 :revision rev-2)
+ (is (eql top-2 (get-item-by-locator "psi-1" :revision rev-0)))
+ (is (eql top-2 (get-item-by-locator "psi-2" :revision rev-0)))
(is (eql top-2 (get-item-by-locator "psi-1" :revision 500)))
- (is-false (get-item-by-locator "psi-2" :revision revision))
- (delete-psi top-2 psi-1 :revision revision-2)
- (is-false (get-item-by-locator "psi-1"))
- (is (eql top-2 (get-item-by-locator "psi-1" :revision revision)))
- (add-psi top-3 psi-1 :revision revision-2)
- (is (eql top-2 (get-item-by-locator "psi-1" :revision revision)))
- (d::add-to-version-history top-3 :start-revision revision-2)
- (is (eql top-3 (get-item-by-locator "psi-1"))))))
+ (is-false (get-item-by-locator "psi-2" :revision rev-1))
+ (delete-psi top-2 psi-1 :revision rev-2)
+ (is-false (get-item-by-locator "psi-1" :revision rev-0))
+ (is (eql top-2 (get-item-by-locator "psi-1" :revision rev-1)))
+ (add-psi top-3 psi-1 :revision rev-2)
+ (is (eql top-2 (get-item-by-locator "psi-1" :revision rev-1)))
+ (d::add-to-version-history top-3 :start-revision rev-2)
+ (is (eql top-3 (get-item-by-locator "psi-1" :revision rev-0))))))
(test test-ReifiableConstructC ()
@@ -621,81 +637,82 @@
(occ-2 (make-instance 'OccurrenceC))
(top-1 (make-instance 'TopicC))
(top-2 (make-instance 'TopicC))
- (revision-1 100)
- (revision-2 200)
- (revision-3 300)
- (revision-4 400)
- (revision-5 500)
- (revision-6 600)
- (revision-7 700)
- (revision-8 800))
- (setf *TM-REVISION* revision-1)
- (is-false (parent occ-1))
- (is-false (occurrences top-1))
- (add-occurrence top-1 occ-1 :revision revision-1)
+ (rev-0 0)
+ (rev-1 100)
+ (rev-2 200)
+ (rev-3 300)
+ (rev-4 400)
+ (rev-5 500)
+ (rev-6 600)
+ (rev-7 700)
+ (rev-8 800))
+ (setf *TM-REVISION* rev-1)
+ (is-false (parent occ-1 :revision rev-0))
+ (is-false (occurrences top-1 :revision rev-0))
+ (add-occurrence top-1 occ-1 :revision rev-1)
(is (= (length (d::versions top-1)) 1))
(is-true (find-if #'(lambda(vi)
- (and (= (d::start-revision vi) revision-1)
+ (and (= (d::start-revision vi) rev-1)
(= (d::end-revision vi) 0)))
(d::versions top-1)))
(is (= (length (union (list occ-1)
- (occurrences top-1))) 1))
- (add-occurrence top-1 occ-2 :revision revision-2)
+ (occurrences top-1 :revision rev-0))) 1))
+ (add-occurrence top-1 occ-2 :revision rev-2)
(is (= (length (d::versions top-1)) 2))
(is-true (find-if #'(lambda(vi)
- (and (= (d::start-revision vi) revision-2)
+ (and (= (d::start-revision vi) rev-2)
(= (d::end-revision vi) 0)))
(d::versions top-1)))
(is (= (length (union (list occ-1 occ-2)
- (occurrences top-1))) 2))
+ (occurrences top-1 :revision rev-0))) 2))
(is (= (length (union (list occ-1)
- (occurrences top-1 :revision revision-1))) 1))
- (add-occurrence top-1 occ-2 :revision revision-3)
+ (occurrences top-1 :revision rev-1))) 1))
+ (add-occurrence top-1 occ-2 :revision rev-3)
(is (= (length (d::slot-p top-1 'd::occurrences)) 2))
- (delete-occurrence top-1 occ-1 :revision revision-4)
+ (delete-occurrence top-1 occ-1 :revision rev-4)
(is (= (length (d::versions top-1)) 4))
(is-true (find-if #'(lambda(vi)
- (and (= (d::start-revision vi) revision-4)
+ (and (= (d::start-revision vi) rev-4)
(= (d::end-revision vi) 0)))
(d::versions top-1)))
(is (= (length (union (list occ-2)
- (occurrences top-1 :revision revision-4))) 1))
+ (occurrences top-1 :revision rev-4))) 1))
(is (= (length (union (list occ-2)
- (occurrences top-1))) 1))
+ (occurrences top-1 :revision rev-0))) 1))
(is (= (length (union (list occ-1 occ-2)
- (occurrences top-1 :revision revision-2))) 2))
- (add-occurrence top-1 occ-1 :revision revision-4)
+ (occurrences top-1 :revision rev-2))) 2))
+ (add-occurrence top-1 occ-1 :revision rev-4)
(is (= (length (union (list occ-2 occ-1)
- (occurrences top-1))) 2))
- (signals error (add-occurrence top-2 occ-1 :revision revision-4))
- (delete-occurrence top-1 occ-1 :revision revision-5)
+ (occurrences top-1 :revision rev-0))) 2))
+ (signals 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 revision-5))) 1))
- (add-occurrence top-2 occ-1 :revision revision-5)
- (is (eql (parent occ-1) top-2))
- (is (eql (parent occ-1 :revision revision-2) top-1))
- (delete-parent occ-2 top-1 :revision revision-4)
- (is-false (parent occ-2 :revision revision-4))
- (is (eql top-1 (parent occ-2 :revision revision-3)))
- (add-parent occ-2 top-1 :revision revision-5)
- (is-false (parent occ-2 :revision revision-4))
- (is (eql top-1 (parent occ-2)))
- (delete-parent occ-2 top-1 :revision revision-6)
- (add-parent occ-2 top-2 :revision revision-7)
+ (occurrences top-1 :revision rev-5))) 1))
+ (add-occurrence top-2 occ-1 :revision rev-5)
+ (is (eql (parent occ-1 :revision rev-0) top-2))
+ (is (eql (parent occ-1 :revision rev-2) top-1))
+ (delete-parent occ-2 top-1 :revision rev-4)
+ (is-false (parent occ-2 :revision rev-4))
+ (is (eql top-1 (parent occ-2 :revision rev-3)))
+ (add-parent occ-2 top-1 :revision rev-5)
+ (is-false (parent occ-2 :revision rev-4))
+ (is (eql top-1 (parent occ-2 :revision rev-0)))
+ (delete-parent occ-2 top-1 :revision rev-6)
+ (add-parent occ-2 top-2 :revision rev-7)
(is (= (length (d::versions top-2)) 2))
(is-true (find-if #'(lambda(vi)
- (and (= (d::start-revision vi) revision-7)
+ (and (= (d::start-revision vi) rev-7)
(= (d::end-revision vi) 0)))
(d::versions top-2)))
- (delete-parent occ-2 top-2 :revision revision-8)
+ (delete-parent occ-2 top-2 :revision rev-8)
(is (= (length (d::versions top-2)) 3))
(is-true (find-if #'(lambda(vi)
- (and (= (d::start-revision vi) revision-8)
+ (and (= (d::start-revision vi) rev-8)
(= (d::end-revision vi) 0)))
(d::versions top-2)))
- (is-false (parent occ-2))
- (add-parent occ-2 top-1 :revision revision-8)
- (is (eql top-1 (parent occ-2))))))
+ (is-false (parent occ-2 :revision rev-0))
+ (add-parent occ-2 top-1 :revision rev-8)
+ (is (eql top-1 (parent occ-2 :revision rev-0))))))
(test test-VariantC ()
@@ -705,56 +722,57 @@
(v-2 (make-instance 'VariantC))
(name-1 (make-instance 'NameC))
(name-2 (make-instance 'NameC))
- (revision-1 100)
- (revision-2 200)
- (revision-3 300)
- (revision-4 400)
- (revision-5 500)
- (revision-6 600)
- (revision-7 700)
- (revision-8 800))
- (setf *TM-REVISION* revision-1)
- (is-false (parent v-1))
- (is-false (variants name-1))
- (add-variant name-1 v-1 :revision revision-1)
+ (rev-0 0)
+ (rev-1 100)
+ (rev-2 200)
+ (rev-3 300)
+ (rev-4 400)
+ (rev-5 500)
+ (rev-6 600)
+ (rev-7 700)
+ (rev-8 800))
+ (setf *TM-REVISION* rev-1)
+ (is-false (parent v-1 :revision rev-0))
+ (is-false (variants name-1 :revision rev-0))
+ (add-variant name-1 v-1 :revision rev-1)
(is (= (length (union (list v-1)
- (variants name-1))) 1))
- (add-variant name-1 v-2 :revision revision-2)
+ (variants name-1 :revision rev-0))) 1))
+ (add-variant name-1 v-2 :revision rev-2)
(is (= (length (union (list v-1 v-2)
- (variants name-1))) 2))
+ (variants name-1 :revision rev-0))) 2))
(is (= (length (union (list v-1)
- (variants name-1 :revision revision-1))) 1))
- (add-variant name-1 v-2 :revision revision-3)
+ (variants name-1 :revision rev-1))) 1))
+ (add-variant name-1 v-2 :revision rev-3)
(is (= (length (d::slot-p name-1 'd::variants)) 2))
- (delete-variant name-1 v-1 :revision revision-4)
+ (delete-variant name-1 v-1 :revision rev-4)
(is (= (length (union (list v-2)
- (variants name-1 :revision revision-4))) 1))
+ (variants name-1 :revision rev-4))) 1))
(is (= (length (union (list v-2)
- (variants name-1))) 1))
+ (variants name-1 :revision rev-0))) 1))
(is (= (length (union (list v-1 v-2)
- (variants name-1 :revision revision-2))) 2))
- (add-variant name-1 v-1 :revision revision-4)
+ (variants name-1 :revision rev-2))) 2))
+ (add-variant name-1 v-1 :revision rev-4)
(is (= (length (union (list v-2 v-1)
- (variants name-1))) 2))
- (signals error (add-variant name-2 v-1 :revision revision-4))
- (delete-variant name-1 v-1 :revision revision-5)
+ (variants name-1 :revision rev-0))) 2))
+ (signals 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 revision-5))) 1))
- (add-variant name-2 v-1 :revision revision-5)
- (is (eql (parent v-1) name-2))
- (is (eql (parent v-1 :revision revision-2) name-1))
- (delete-parent v-2 name-1 :revision revision-4)
- (is-false (parent v-2 :revision revision-4))
- (is (eql name-1 (parent v-2 :revision revision-3)))
- (add-parent v-2 name-1 :revision revision-5)
- (is-false (parent v-2 :revision revision-4))
- (is (eql name-1 (parent v-2)))
- (delete-parent v-2 name-1 :revision revision-6)
- (add-parent v-2 name-2 :revision revision-7)
- (delete-parent v-2 name-2 :revision revision-8)
- (is-false (parent v-2))
- (add-parent v-2 name-1 :revision revision-8)
- (is (eql name-1 (parent v-2))))))
+ (variants name-1 :revision rev-5))) 1))
+ (add-variant name-2 v-1 :revision rev-5)
+ (is (eql (parent v-1 :revision rev-0) name-2))
+ (is (eql (parent v-1 :revision rev-2) name-1))
+ (delete-parent v-2 name-1 :revision rev-4)
+ (is-false (parent v-2 :revision rev-4))
+ (is (eql name-1 (parent v-2 :revision rev-3)))
+ (add-parent v-2 name-1 :revision rev-5)
+ (is-false (parent v-2 :revision rev-4))
+ (is (eql name-1 (parent v-2 :revision rev-0)))
+ (delete-parent v-2 name-1 :revision rev-6)
+ (add-parent v-2 name-2 :revision rev-7)
+ (delete-parent v-2 name-2 :revision rev-8)
+ (is-false (parent v-2 :revision rev-0))
+ (add-parent v-2 name-1 :revision rev-8)
+ (is (eql name-1 (parent v-2 :revision rev-0))))))
(test test-NameC ()
@@ -764,81 +782,82 @@
(name-2 (make-instance 'NameC))
(top-1 (make-instance 'TopicC))
(top-2 (make-instance 'TopicC))
- (revision-1 100)
- (revision-2 200)
- (revision-3 300)
- (revision-4 400)
- (revision-5 500)
- (revision-6 600)
- (revision-7 700)
- (revision-8 800))
- (setf *TM-REVISION* revision-1)
- (is-false (parent name-1))
- (is-false (names top-1))
- (add-name top-1 name-1 :revision revision-1)
+ (rev-0 0)
+ (rev-1 100)
+ (rev-2 200)
+ (rev-3 300)
+ (rev-4 400)
+ (rev-5 500)
+ (rev-6 600)
+ (rev-7 700)
+ (rev-8 800))
+ (setf *TM-REVISION* rev-1)
+ (is-false (parent name-1 :revision rev-0))
+ (is-false (names top-1 :revision rev-0))
+ (add-name top-1 name-1 :revision rev-1)
(is (= (length (d::versions top-1)) 1))
(is-true (find-if #'(lambda(vi)
- (and (= (d::start-revision vi) revision-1)
+ (and (= (d::start-revision vi) rev-1)
(= (d::end-revision vi) 0)))
(d::versions top-1)))
(is (= (length (union (list name-1)
- (names top-1))) 1))
- (add-name top-1 name-2 :revision revision-2)
+ (names top-1 :revision rev-0))) 1))
+ (add-name top-1 name-2 :revision rev-2)
(is (= (length (d::versions top-1)) 2))
(is-true (find-if #'(lambda(vi)
- (and (= (d::start-revision vi) revision-2)
+ (and (= (d::start-revision vi) rev-2)
(= (d::end-revision vi) 0)))
(d::versions top-1)))
(is (= (length (union (list name-1 name-2)
- (names top-1))) 2))
+ (names top-1 :revision rev-0))) 2))
(is (= (length (union (list name-1)
- (names top-1 :revision revision-1))) 1))
- (add-name top-1 name-2 :revision revision-3)
+ (names top-1 :revision rev-1))) 1))
+ (add-name top-1 name-2 :revision rev-3)
(is (= (length (d::slot-p top-1 'd::names)) 2))
- (delete-name top-1 name-1 :revision revision-4)
+ (delete-name top-1 name-1 :revision rev-4)
(is (= (length (d::versions top-1)) 4))
(is-true (find-if #'(lambda(vi)
- (and (= (d::start-revision vi) revision-4)
+ (and (= (d::start-revision vi) rev-4)
(= (d::end-revision vi) 0)))
(d::versions top-1)))
(is (= (length (union (list name-2)
- (names top-1 :revision revision-4))) 1))
+ (names top-1 :revision rev-4))) 1))
(is (= (length (union (list name-2)
- (names top-1))) 1))
+ (names top-1 :revision rev-0))) 1))
(is (= (length (union (list name-1 name-2)
- (names top-1 :revision revision-2))) 2))
- (add-name top-1 name-1 :revision revision-4)
+ (names top-1 :revision rev-2))) 2))
+ (add-name top-1 name-1 :revision rev-4)
(is (= (length (union (list name-2 name-1)
- (names top-1))) 2))
- (signals error (add-name top-2 name-1 :revision revision-4))
- (delete-name top-1 name-1 :revision revision-5)
+ (names top-1 :revision rev-0))) 2))
+ (signals 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 revision-5))) 1))
- (add-name top-2 name-1 :revision revision-5)
- (is (eql (parent name-1) top-2))
- (is (eql (parent name-1 :revision revision-2) top-1))
- (delete-parent name-2 top-1 :revision revision-4)
- (is-false (parent name-2 :revision revision-4))
- (is (eql top-1 (parent name-2 :revision revision-3)))
- (add-parent name-2 top-1 :revision revision-5)
- (is-false (parent name-2 :revision revision-4))
- (is (eql top-1 (parent name-2)))
- (delete-parent name-2 top-1 :revision revision-6)
- (add-parent name-2 top-2 :revision revision-7)
+ (names top-1 :revision rev-5))) 1))
+ (add-name top-2 name-1 :revision rev-5)
+ (is (eql (parent name-1 :revision rev-0) top-2))
+ (is (eql (parent name-1 :revision rev-2) top-1))
+ (delete-parent name-2 top-1 :revision rev-4)
+ (is-false (parent name-2 :revision rev-4))
+ (is (eql top-1 (parent name-2 :revision rev-3)))
+ (add-parent name-2 top-1 :revision rev-5)
+ (is-false (parent name-2 :revision rev-4))
+ (is (eql top-1 (parent name-2 :revision rev-0)))
+ (delete-parent name-2 top-1 :revision rev-6)
+ (add-parent name-2 top-2 :revision rev-7)
(is (= (length (d::versions top-2)) 2))
(is-true (find-if #'(lambda(vi)
- (and (= (d::start-revision vi) revision-7)
+ (and (= (d::start-revision vi) rev-7)
(= (d::end-revision vi) 0)))
(d::versions top-2)))
- (delete-parent name-2 top-2 :revision revision-8)
+ (delete-parent name-2 top-2 :revision rev-8)
(is (= (length (d::versions top-2)) 3))
(is-true (find-if #'(lambda(vi)
- (and (= (d::start-revision vi) revision-8)
+ (and (= (d::start-revision vi) rev-8)
(= (d::end-revision vi) 0)))
(d::versions top-2)))
- (is-false (parent name-2))
- (add-parent name-2 top-1 :revision revision-8)
- (is (eql top-1 (parent name-2))))))
+ (is-false (parent name-2 :revision rev-0))
+ (add-parent name-2 top-1 :revision rev-8)
+ (is (eql top-1 (parent name-2 :revision rev-0))))))
(test test-TypableC ()
@@ -848,31 +867,31 @@
(name-2 (make-instance 'NameC))
(top-1 (make-instance 'TopicC))
(top-2 (make-instance 'TopicC))
+ (revision-0 0)
(revision-0-5 50)
(revision-1 100)
(revision-2 200)
(revision-3 300))
(setf *TM-REVISION* revision-1)
- (is-false (instance-of name-1))
+ (is-false (instance-of name-1 :revision revision-0))
(add-type name-1 top-1)
(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))
+ (signals 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))) 2))
+ (used-as-type top-1 :revision revision-0))) 2))
(is (= (length (union (list name-1)
- (used-as-type top-1
- :revision revision-1))) 1))
+ (used-as-type top-1 :revision revision-1))) 1))
(delete-type name-1 top-1 :revision revision-3)
- (is-false (instance-of name-1))
+ (is-false (instance-of name-1 :revision revision-0))
(is (= (length (union (list name-2)
- (used-as-type top-1))) 1))
+ (used-as-type top-1 :revision revision-0))) 1))
(add-type name-1 top-1 :revision revision-3)
- (is (eql top-1 (instance-of name-1)))
+ (is (eql top-1 (instance-of name-1 :revision revision-0)))
(is (= (length (union (list name-1 name-2)
- (used-as-type top-1))) 2))
+ (used-as-type top-1 :revision revision-0))) 2))
(is (= (length (slot-value top-1 'd::used-as-type)) 2)))))
@@ -883,43 +902,44 @@
(occ-2 (make-instance 'OccurrenceC))
(top-1 (make-instance 'TopicC))
(top-2 (make-instance 'TopicC))
+ (revision-0 0)
(revision-1 100)
(revision-2 200)
(revision-3 300))
(setf *TM-REVISION* revision-1)
- (is-false (themes occ-1))
- (is-false (used-as-theme top-1))
+ (is-false (themes occ-1 :revision revision-0))
+ (is-false (used-as-theme top-1 :revision revision-0))
(add-theme occ-1 top-1)
(is (= (length (union (list top-1)
- (themes occ-1))) 1))
+ (themes occ-1 :revision revision-0))) 1))
(is (= (length (union (list occ-1)
- (used-as-theme top-1))) 1))
+ (used-as-theme top-1 :revision revision-0))) 1))
(delete-theme occ-1 top-1 :revision revision-2)
(is (= (length (union (list top-1)
(themes occ-1 :revision revision-1))) 1))
- (is-false (themes occ-1))
- (is-false (used-as-theme top-1))
+ (is-false (themes occ-1 :revision revision-0))
+ (is-false (used-as-theme top-1 :revision revision-0))
(is-false (themes occ-1 :revision revision-2))
(add-theme occ-1 top-1 :revision revision-3)
(is (= (length (union (list top-1)
- (themes occ-1))) 1))
+ (themes occ-1 :revision revision-0))) 1))
(is (= (length (slot-value occ-1 'd::themes)) 1))
(add-theme occ-1 top-2 :revision revision-2)
(is (= (length (union (list top-1 top-2)
- (themes occ-1))) 2))
+ (themes occ-1 :revision revision-0))) 2))
(is (= (length (union (list top-2)
(themes occ-1 :revision revision-2))) 1))
(is (= (length (union (list top-1 top-2)
- (themes occ-1))) 2))
+ (themes occ-1 :revision revision-0))) 2))
(add-theme occ-2 top-2 :revision revision-3)
(is (= (length (union (list top-1 top-2)
- (themes occ-1))) 2))
+ (themes occ-1 :revision revision-0))) 2))
(is (= (length (union (list top-2)
- (themes occ-2))) 1))
+ (themes occ-2 :revision revision-0))) 1))
(is (= (length (union (list occ-1)
- (used-as-theme top-1))) 1))
+ (used-as-theme top-1 :revision revision-0))) 1))
(is (= (length (union (list occ-1 occ-2)
- (used-as-theme top-2))) 2))
+ (used-as-theme top-2 :revision revision-0))) 2))
(is (= (length (slot-value occ-1 'd::themes)) 2))
(is (= (length (slot-value occ-2 'd::themes)) 1))
(is (= (length (slot-value top-1 'd::used-as-theme)) 1))
@@ -933,67 +953,68 @@
(role-2 (make-instance 'RoleC))
(assoc-1 (make-instance 'AssociationC))
(assoc-2 (make-instance 'AssociationC))
- (revision-1 100)
- (revision-2 200)
- (revision-3 300)
- (revision-4 400))
- (setf *TM-REVISION* revision-1)
- (is-false (roles assoc-1))
- (is-false (parent role-1))
+ (rev-0 0)
+ (rev-1 100)
+ (rev-2 200)
+ (rev-3 300)
+ (rev-4 400))
+ (setf *TM-REVISION* rev-1)
+ (is-false (roles assoc-1 :revision rev-0))
+ (is-false (parent role-1 :revision rev-0))
(add-parent role-1 assoc-1)
(is (= (length (d::versions assoc-1)) 1))
(is-true (find-if #'(lambda(vi)
- (and (= (d::start-revision vi) revision-1)
+ (and (= (d::start-revision vi) rev-1)
(= (d::end-revision vi) 0)))
(d::versions assoc-1)))
- (is (eql (parent role-1 :revision revision-1) assoc-1))
+ (is (eql (parent role-1 :revision rev-1) assoc-1))
(is (= (length (union (list role-1)
(roles assoc-1))) 1))
- (add-role assoc-1 role-2 :revision revision-2)
+ (add-role assoc-1 role-2 :revision rev-2)
(is (= (length (d::versions assoc-1)) 2))
(is-true (find-if #'(lambda(vi)
- (and (= (d::start-revision vi) revision-2)
+ (and (= (d::start-revision vi) rev-2)
(= (d::end-revision vi) 0)))
(d::versions assoc-1)))
(is (= (length (union (list role-1 role-2)
- (roles assoc-1))) 2))
+ (roles assoc-1 :revision rev-0))) 2))
(is (= (length (union (list role-1)
- (roles assoc-1 :revision revision-1))) 1))
- (is (eql (parent role-1) assoc-1))
- (is (eql (parent role-2 :revision revision-2) assoc-1))
- (is-false (parent role-2 :revision revision-1))
- (signals error (add-parent role-2 assoc-2 :revision revision-2))
- (delete-role assoc-1 role-1 :revision revision-3)
+ (roles assoc-1 :revision rev-1))) 1))
+ (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))
+ (delete-role assoc-1 role-1 :revision rev-3)
(is (= (length (d::versions assoc-1)) 3))
(is-true (find-if #'(lambda(vi)
- (and (= (d::start-revision vi) revision-3)
+ (and (= (d::start-revision vi) rev-3)
(= (d::end-revision vi) 0)))
(d::versions assoc-1)))
- (is-false (parent role-1))
+ (is-false (parent role-1 :revision rev-0))
(is (= (length (union (list role-2)
- (roles assoc-1))) 1))
- (delete-parent role-2 assoc-1 :revision revision-3)
- (is-false (parent role-2))
- (is (eql assoc-1 (parent role-2 :revision revision-2)))
- (is-false (roles assoc-1))
- (add-role assoc-2 role-1 :revision revision-3)
- (add-parent role-2 assoc-2 :revision revision-3)
- (is (eql (parent role-2) assoc-2))
+ (roles assoc-1 :revision rev-0))) 1))
+ (delete-parent role-2 assoc-1 :revision rev-3)
+ (is-false (parent role-2 :revision rev-0))
+ (is (eql assoc-1 (parent role-2 :revision rev-2)))
+ (is-false (roles assoc-1 :revision rev-0))
+ (add-role assoc-2 role-1 :revision rev-3)
+ (add-parent role-2 assoc-2 :revision rev-3)
+ (is (eql (parent role-2 :revision rev-0) assoc-2))
(is (= (length (union (list role-1 role-2)
(roles assoc-2))) 2))
- (add-role assoc-2 role-1 :revision revision-3)
- (add-parent role-2 assoc-2 :revision revision-3)
- (is (eql (parent role-2) assoc-2))
+ (add-role assoc-2 role-1 :revision rev-3)
+ (add-parent role-2 assoc-2 :revision rev-3)
+ (is (eql (parent role-2 :revision rev-0) assoc-2))
(is (= (length (union (list role-1 role-2)
- (roles assoc-2))) 2))
+ (roles assoc-2 :revision rev-0))) 2))
(is (= (length (slot-value assoc-1 'roles)) 2))
(is (= (length (slot-value assoc-2 'roles)) 2))
(is (= (length (slot-value role-1 'parent)) 2))
(is (= (length (slot-value role-2 'parent)) 2))
- (delete-parent role-1 assoc-2 :revision revision-4)
+ (delete-parent role-1 assoc-2 :revision rev-4)
(is (= (length (d::versions assoc-2)) 2))
(is-true (find-if #'(lambda(vi)
- (and (= (d::start-revision vi) revision-4)
+ (and (= (d::start-revision vi) rev-4)
(= (d::end-revision vi) 0)))
(d::versions assoc-2))))))
@@ -1005,35 +1026,36 @@
(role-2 (make-instance 'RoleC))
(top-1 (make-instance 'TopicC))
(top-2 (make-instance 'TopicC))
+ (revision-0 0)
(revision-0-5 50)
(revision-1 100)
(revision-2 200)
(revision-3 300))
(setf *TM-REVISION* revision-1)
- (is-false (player role-1))
+ (is-false (player role-1 :revision revision-0))
(add-player role-1 top-1)
- (is (eql top-1 (player role-1)))
+ (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)))
(add-player role-1 top-1)
- (is (eql top-1 (player role-1)))
+ (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))
(add-player role-2 top-1 :revision revision-2)
(is (= (length (union (list role-1 role-2)
- (player-in-roles top-1))) 2))
+ (player-in-roles top-1 :revision revision-0))) 2))
(is (= (length (union (list role-1)
(player-in-roles top-1
:revision revision-1))) 1))
(delete-player role-1 top-1 :revision revision-3)
- (is-false (player role-1))
+ (is-false (player role-1 :revision revision-0))
(is (= (length (union (list role-2)
- (player-in-roles top-1))) 1))
+ (player-in-roles top-1 :revision revision-0))) 1))
(add-player role-1 top-1 :revision revision-3)
- (is (eql top-1 (player role-1)))
+ (is (eql top-1 (player role-1 :revision revision-0)))
(is (= (length (union (list role-1 role-2)
- (player-in-roles top-1))) 2))
+ (player-in-roles top-1 :revision revision-0))) 2))
(is (= (length (slot-value top-1 'd::player-in-roles)) 2)))))
@@ -1226,6 +1248,7 @@
(reifier-1 (make-instance 'TopicC))
(reifier-2 (make-instance 'TopicC))
(ii-1 (make-instance 'ItemIdentifierC :uri "ii-1"))
+ (revision-0 0)
(revision-1 100)
(revision-2 200))
(setf *TM-REVISION* revision-1)
@@ -1253,7 +1276,7 @@
(is (= (length (elephant:get-instances-by-class 'd::ReifierAssociationC))
1))
(is (= (length (union (list ii-1) (item-identifiers rc-2))) 1))
- (is (eql reifier-1 (reifier rc-2)))
+ (is (eql reifier-1 (reifier rc-2 :revision revision-0)))
(delete-construct ii-1)
(delete-construct reifier-1)
(is (= (length (elephant:get-instances-by-class 'd::ReifiableConstructC))
More information about the Isidorus-cvs
mailing list