[isidorus-cvs] r262 - branches/new-datamodel/src/model
Lukas Giessmann
lgiessmann at common-lisp.net
Tue Apr 6 13:42:50 UTC 2010
Author: lgiessmann
Date: Tue Apr 6 09:42:50 2010
New Revision: 262
Log:
new-datamodel: added "merge-constructs" for "NameC" and "VariantC"
Modified:
branches/new-datamodel/src/model/datamodel.lisp
Modified: branches/new-datamodel/src/model/datamodel.lisp
==============================================================================
--- branches/new-datamodel/src/model/datamodel.lisp (original)
+++ branches/new-datamodel/src/model/datamodel.lisp Tue Apr 6 09:42:50 2010
@@ -876,7 +876,7 @@
(let ((vi-1 (find-version-info (list construct-1)))
(vi-2 (find-version-info (list construct-2))))
(cond ((not (or vi-1 vi-2))
- nil)
+ construct-1)
((not vi-1)
construct-2)
((not vi-2)
@@ -1030,7 +1030,7 @@
(let ((vi-1 (find-version-info (slot-p construct-1 'identified-construct)))
(vi-2 (find-version-info (slot-p construct-2 'identified-construct))))
(cond ((not (or vi-1 vi-2))
- nil)
+ construct-1)
((not vi-1)
construct-2)
((not vi-2)
@@ -1858,7 +1858,7 @@
(let ((vi-1 (find-version-info (slot-p construct-1 'parent)))
(vi-2 (find-version-info (slot-p construct-2 'parent))))
(cond ((not (or vi-1 vi-2))
- nil)
+ construct-1)
((not vi-1)
construct-2)
((not vi-2)
@@ -2278,7 +2278,7 @@
(let ((vi-1 (find-version-info (slot-p construct-1 'parent)))
(vi-2 (find-version-info (slot-p construct-2 'parent))))
(cond ((not (or vi-1 vi-2))
- nil)
+ construct-1)
((not vi-1)
construct-2)
((not vi-2)
@@ -3536,4 +3536,83 @@
-;;; end hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
\ No newline at end of file
+;;; end hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+(defmethod merge-constructs ((construct-1 VariantC) (construct-2 VariantC)
+ &key (revision *TM-REVISION*))
+ (declare (integer revision))
+ (if (eql construct-1 construct-2)
+ construct-1
+ (let ((older-var (find-oldest-construct construct-1 construct-2)))
+ (let ((newer-var (if (eql older-var construct-1)
+ construct-2
+ construct-1)))
+ (let ((parent-1 (parent older-var :revision revision))
+ (parent-2 (parent newer-var :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))
+ (cond ((and parent-1 parent-2)
+ (let ((active-parent
+ (merge-constructs parent-1 parent-2
+ :revision revision)))
+ (let ((all-names (names active-parent :revision revision)))
+ (if (find-if #'(lambda(name)
+ (find older-var (variants name :revision
+ revision)))
+ all-names)
+ older-var
+ newer-var))))
+ ((or parent-1 parent-2)
+ (let ((dst (if parent-1 older-var newer-var))
+ (src (if parent-1 newer-var older-var)))
+ (move-identifiers src dst :revision revision)
+ (move-referenced-constructs src dst :revision revision)
+ dst))
+ (t
+ (move-identifiers newer-var older-var :revision revision)
+ (move-referenced-constructs newer-var older-var
+ :revision revision)
+ older-var)))))))
+
+
+(defmethod merge-constructs ((construct-1 NameC) (construct-2 NameC)
+ &key (revision *TM-REVISION*))
+ (declare (integer revision))
+ (if (eql construct-1 construct-2)
+ construct-1
+ (let ((older-name (find-oldest-construct construct-1 construct-2)))
+ (let ((newer-name (if (eql older-name construct-1)
+ construct-2
+ construct-1)))
+ (let ((parent-1 (parent older-name :revision revision))
+ (parent-2 (parent newer-name :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))
+ (cond ((and parent-1 parent-2)
+ (let ((active-parent (merge-constructs parent-1 parent-2
+ :revision revision)))
+ (if (find older-name (names active-parent
+ :revision revision))
+ older-name
+ newer-name)))
+ ((or parent-1 parent-2)
+ (let ((dst (if parent-1 older-name newer-name))
+ (src (if parent-1 newer-name older-name)))
+ (move-identifiers src dst :revision revision)
+ (move-referenced-constructs src dst :revision revision)
+ (move-variants src dst :revision revision)
+ dst))
+ (t
+ (move-identifiers newer-name older-name :revision revision)
+ (move-referenced-constructs newer-name older-name
+ :revision revision)
+ (move-variants newer-name older-name :revision revision)
+ older-name)))))))
+
+
+;TODO: --> include move-yx in move-referenced-constructs
\ No newline at end of file
More information about the Isidorus-cvs
mailing list