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