source: branches/new-datamodel/src/model/model_tools.lisp

Last change on this file was 26, checked in by lgiessmann, 16 years ago

added a license header to all files where the isidorus license is mentioned and referenced, in the ajax file there is also a reference to the MIT-license; an edit/create template for fragments is implemented in the ajax module, but it\'s really terrible and not really useable - this should be only the initial idea of realizing such a functionality\!
  • Property svn:eol-style set to native
File size: 1.9 KB
Line 
1;;+-----------------------------------------------------------------------------
2;;+  Isidorus
3;;+  (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann
4;;+
5;;+  Isidorus is freely distributable under the LGPL license.
6;;+  You can find a detailed description in trunk/docs/LGPL-LICENSE.txt.
7;;+-----------------------------------------------------------------------------
8
9
10(in-package :datamodel)
11
12(defgeneric equalT (construct1 construct2)
13  (:documentation "Test for full equality of two elephant objects"))
14
15(defmethod equalT ((x TopicMapConstructC) (y TopicMapConstructC))
16  (when (equal (type-of x) (type-of y))
17    (loop for slot in (sb-pcl:class-slots (find-class (type-of x)))
18
19       ;; does not compare the OID and the DBCONNECTION-SPEC-PST slot
20       when(and (not (equal (symbol-name (sb-pcl:slot-definition-name slot)) "OID"))
21                (not (equal (symbol-name (sb-pcl:slot-definition-name slot)) "DBCONNECTION-SPEC-PST")))
22
23       ;; iterates through all lists in the 'TopicMapConstructC
24       do (if (equal 'CONS (type-of (slot-value x (sb-pcl:slot-definition-name slot))))
25              (loop for item-x in (slot-value x (sb-pcl:slot-definition-name slot))
26                 for item-y in (slot-value y (sb-pcl:slot-definition-name slot))
27                 do (if (typep item-x 'TopicMapConstructC)
28                        (when (not (equalT item-x item-y))
29                          (return-from equalT nil))
30                        (when (not (equal item-x item-y))
31                          (return-from equalT nil))))
32
33              ;; (else - not 'CONS) atomic values
34              (if (typep (sb-pcl:slot-definition-name slot) 'TopicMapConstructC)
35                  (when (not (equalT (slot-value x (sb-pcl:slot-definition-name slot))
36                                     (slot-value y (sb-pcl:slot-definition-name slot))))
37                             (return-from equalT nil))
38                  (when (not (equal (slot-value x (sb-pcl:slot-definition-name slot))
39                                    (slot-value y (sb-pcl:slot-definition-name slot))))
40                    (return-from equalT nil))))
41         (return-from equalT t)))
42  nil)
Note: See TracBrowser for help on using the repository browser.