[isidorus-cvs] r239 - branches/new-datamodel/src/model

[Lukas Giessmann]

Author: lgiessmann
Date: Sun Mar 21 13:26:05 2010
New Revision: 239

Log:
new-datamodel: optimized "make-construct"

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	Sun Mar 21 13:26:05 2010
@@ -2534,17 +2534,19 @@
   (let ((construct
 	 (cond
 	   ((PointerC-p class-symbol)
-	    (make-pointer class-symbol (getf args :uri) args))
+	    (apply #'make-pointer class-symbol args))
 	   ((CharacteristicC-p class-symbol)
-	    (make-characteristic class-symbol args))
+	    (apply #'make-characteristic class-symbol args))
 	   ((TopicC-p class-symbol)
-	    (make-topic args))
+	    (apply #'make-topic args))
 	   ((TopicMapC-p class-symbol)
-	    (make-tm args))
+	    (apply #'make-tm args))
 	   ((RoleC-p class-symbol)
-	    (make-role args))
+	    (apply #'make-role args))
 	   ((AssociationC-p class-symbol)
-	    (make-association args))))
+	    (apply #'make-association args))
+	   (t
+	    (apply #'make-instance class-symbol args))))
 	(start-revision (getf args :start-revision)))
     (when (typep construct 'TypableC)
       (complete-typable construct (getf args :instance-of)
@@ -2552,6 +2554,10 @@
     (when (typep construct 'ScopableC)
       (complete-scopable construct (getf args :themes)
 			 :start-revision start-revision))
+    (when (typep construct 'VersionedConstructC)
+      (unless start-revision
+	(error "From make-construct(): start-revision must be set"))
+      (add-to-version-history construct :start-revision start-revision))
     (if (typep construct 'ReifiableConstructC)
 	(complete-reifiable construct (getf args :item-identtifiers)
 			    (getf args :reifier) :start-revision start-revision)
@@ -2562,14 +2568,13 @@
   "Returns an association object. If the association has already existed the
    existing one is returned otherwise a new one is created.
    This function exists only for being used by make-construct!"
-  (let ((instance-of (getf (first args) :instance-of))
-	(start-revision (getf (first args) :start-revision))
-	(themes (get (first args) :themes))
-	(roles (get (first args) :roles))
-	(err "From make-association(): "))
-    (unless start-revision (error "~astart-revision must be set" err))
-    (unless roles (error "~aroles must be set" err))
-    (unless instance-of (error "~ainstance-of must be set" err))
+  (let ((instance-of (getf args :instance-of))
+	(start-revision (getf args :start-revision))
+	(themes (get args :themes))
+	(roles (get args :roles)))
+    (when (and (or roles instance-of themes)
+	       (not start-revision))
+      (error "From make-association(): start-revision must be set"))
     (let ((association
 	   (let ((existing-association
 		  (remove-if
@@ -2597,11 +2602,10 @@
   (let ((parent (getf args :parent))
 	(instance-of (getf args :instance-of))
 	(player (getf args :player))
-	(start-revision (getf args :start-revision))
-	(err "From make-role(): "))
-    (unless start-revision (error "~astart-revision must be set" err))
-    (unless instance-of (error "~ainstance-of must be set" err))
-    (unless player (error "~aplayer must be set" err))
+	(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"))
     (let ((role
 	   (let ((existing-role
 		  (remove-if
@@ -2631,10 +2635,10 @@
 	(reifier (getf args :reifier))
 	(topics (getf args :topics))
 	(assocs (getf args :associations))
-	(start-revision (getf args :start-revision))
-	(err "From make-tm(): "))
-    (unless item-identifiers (error "~aitem-identifiers must be set" err))
-    (unless start-revision (error "~astart-revision must be set" err))
+	(start-revision (getf args :start-revision)))
+    (when (and (or item-identifiers reifier)
+	       (not start-revision))
+      (error "From make-tm(): start-revision must be set"))
     (let ((tm
 	   (let ((existing-tms
 		  (remove-if
@@ -2667,10 +2671,11 @@
 	(item-identifiers (getf args :item-identifiers))
 	(topic-identifiers (getf args :topic-identifiers))
 	(names (getf args :names))
-	(occurrences (getf args :occurrences))
-	(err "From make-topic(): "))
-    (unless topic-identifiers (error "~atopic-identifiers must be set" err))
-    (unless start-revision (error "~astart-revision must be set" err))
+	(occurrences (getf args :occurrences)))
+    (when (and (or psis locators item-identifiers topic-identifiers
+		   names occurrences)
+	       (not start-revision))
+      (error "From make-topic(): start-revision must be set"))
     (let ((topic
 	   (let ((existing-topics
 		  (remove-if
@@ -2711,19 +2716,16 @@
    To check if there is existing an equivalent construct the parameter
    parent-construct must be set.
    This function only exists for being used by make-construct!"
-  (let ((charvalue (getf (first args) :charvalue))
-	(start-revision (getf (first args) :start-revision))
-	(datatype (getf (first args) :datatype))
-	(instance-of (getf (first args) :instance-of))
-	(themes (getf (first args) :themes))
-	(variants (getf (first args) :variants))
-	(parent (getf (first args) :parent))
-	(err "From make-characteristic(): "))
-    (unless start-revision (error "~astart-revision must be set" err))
-    (unless charvalue (error "~acharvalue must be set" err))
-    (when (and (or (OccurrenceC-p class-symbol) (NameC-p class-symbol))
-	       (not instance-of))
-      (error "~ainstance-of must be set" err))
+  (let ((charvalue (getf args :charvalue))
+	(start-revision (getf args :start-revision))
+	(datatype (getf args :datatype))
+	(instance-of (getf args :instance-of))
+	(themes (getf args :themes))
+	(variants (getf args :variants))
+	(parent (getf args :parent)))
+    (when (and (or instance-of themes variants parent)
+	       (not start-revision))
+      (error "From make-characteristic(): start-revision must be set"))
     (let ((characteristic
 	   (let ((existing-characteristic
 		  (when parent
@@ -2752,13 +2754,12 @@
   "Returns a pointer object with the specified parameters.
    If an equivalen construct has already existed this one is returned.
    This function only exists for beoing used by make-construct!"
-  (let ((uri (getf (first args) :uri))
-	(xtm-id (getf (first args) :xtm-id))
-	(start-revision (getf (first args) :start-revision))
-	(identified-construct (getf (first args) :identified-construct))
-	(err "From make-pointer(): "))
+  (let ((uri (getf args :uri))
+	(xtm-id (getf args :xtm-id))
+	(start-revision (getf args :start-revision))
+	(identified-construct (getf args :identified-construct)))
     (when (and identified-construct (not start-revision))
-      (error "~astart-revision must be set" err))
+      (error "From make-pointer(): start-revision must be set"))
     (let ((identifier
 	   (let ((existing-pointer
 		  (remove-if