[isidorus-cvs] r335 - trunk/src/model
Lukas Giessmann
lgiessmann at common-lisp.net
Tue Nov 9 20:52:20 UTC 2010
Author: lgiessmann
Date: Tue Nov 9 15:52:19 2010
New Revision: 335
Log:
changed the function invoke-on, so an additional cast-operation can't be passed, since the casting can be done in the main-operation directly; added the functions: names-by-type, names-by-value, occurrences-by-type, occurrences-by-value, characterisitcs-by-type, characterisitcs-by-value; added the condition bad-type-error
Modified:
trunk/src/model/datamodel.lisp
trunk/src/model/exceptions.lisp
trunk/src/model/trivial-queries.lisp
Modified: trunk/src/model/datamodel.lisp
==============================================================================
--- trunk/src/model/datamodel.lisp (original)
+++ trunk/src/model/datamodel.lisp Tue Nov 9 15:52:19 2010
@@ -15,7 +15,8 @@
object-not-found-error
missing-argument-error
not-mergable-error
- tm-reference-error)
+ tm-reference-error
+ bad-type-error)
(:import-from :constants
*xml-string*
*instance-psi*)
@@ -167,7 +168,13 @@
:direct-supertypes
:supertypes
:direct-instance-of
- :invoke-on))
+ :invoke-on
+ :names-by-type
+ :occurrencs-by-type
+ :characteristics-by-type
+ :occurrences-by-value
+ :names-by-value
+ :characteristics-by-value))
(in-package :datamodel)
@@ -648,6 +655,14 @@
:new-reference new-reference))
+(defun make-bad-type-condition (message expected-type result-object)
+ (make-condition
+ 'bad-type-error
+ :message message
+ :expected-type expected-type
+ :result-object result-object))
+
+
(defun make-not-mergable-condition (message construct-1 construct-2)
"Returns a not-mergable-condition with the passed arguments."
(make-condition 'not-mergable-error
Modified: trunk/src/model/exceptions.lisp
==============================================================================
--- trunk/src/model/exceptions.lisp (original)
+++ trunk/src/model/exceptions.lisp Tue Nov 9 15:52:19 2010
@@ -16,7 +16,8 @@
:object-not-found-error
:not-mergable-error
:missing-argument-error
- :tm-reference-error))
+ :tm-reference-error
+ :bad-type-error))
(in-package :exceptions)
@@ -103,6 +104,20 @@
(new-reference
:initarg :new-reference
:accessor new-reference))
- (:documentation "Thrown of the referenced-construct is already owned by another
+ (:documentation "Thrown if the referenced-construct is already owned by another
TM-construct (existing-reference) and is going to be referenced
- by a second TM-construct (new-reference) at the same time."))
\ No newline at end of file
+ by a second TM-construct (new-reference) at the same time."))
+
+
+(define-condition bad-type-error (error)
+ ((message
+ :initarg :message
+ :accessor message)
+ (expected-type
+ :initarg :expected-type
+ :accessor expected-type)
+ (result-object
+ :initarg :result-object
+ :accessor result-object))
+ (:documentation "Thrown if a bad result object with respect to the expected
+ type was found."))
\ No newline at end of file
Modified: trunk/src/model/trivial-queries.lisp
==============================================================================
--- trunk/src/model/trivial-queries.lisp (original)
+++ trunk/src/model/trivial-queries.lisp Tue Nov 9 15:52:19 2010
@@ -225,15 +225,88 @@
(remove-if #'null all-types)))))
-(defgeneric invoke-on (construct main-operation &key cast-operation)
+(defgeneric invoke-on (construct operation)
(:documentation "Invokes the passed main operation on the characteristic's
value.
If cast-operation is set to a function the characteristic's
value is first casted by the cast-operation to another type
and afterwords processed by main-opertion.")
- (:method ((construct TopicC) (main-operation Function) &key cast-operation)
- (declare (type (or Null Function) cast-operation))
- (let ((value (if cast-operation
- (apply cast-operation (list (charvalue construct)))
- (charvalue construct))))
- (funcall main-operation value))))
\ No newline at end of file
+ (:method ((construct TopicC) (operation Function))
+ (funcall operation (charvalue construct))))
+
+
+(defgeneric names-by-type (construct type-identifier &key revision)
+ (:documentation "Returns all names that are of the corresponding type.")
+ (:method ((construct TopicC) (type-identifier IdentifierC)
+ &key (revision *TM-REVISION*))
+ (declare (integer revision))
+ (let ((type-topic (identified-construct type-identifier :revision revision)))
+ (unless (typep type-topic 'TopicC)
+ (error (make-bad-type-condition (format nil "from name-by-type(): expected a topic as instance-of but found ~a" (type-of type-topic)) 'TopicC type-topic)))
+ (let ((results
+ (map 'list #'(lambda(name)
+ (when (instance-of name :revision revision)
+ name))
+ (names construct :revision revision))))
+ (remove-if #'null results)))))
+
+
+(defgeneric occurrences-by-type (construct type-identifier &key revision)
+ (:documentation "Returns all names that are of the corresponding type.")
+ (:method ((construct TopicC) (type-identifier IdentifierC)
+ &key (revision *TM-REVISION*))
+ (declare (integer revision))
+ (let ((type-topic (identified-construct type-identifier :revision revision)))
+ (unless (typep type-topic 'TopicC)
+ (error (make-bad-type-condition (format nil "from occurrence-by-type(): expected a topic as instance-of but found ~a" (type-of type-topic)) 'TopicC type-topic)))
+ (let ((results
+ (map 'list #'(lambda(occ)
+ (when (instance-of occ :revision revision)
+ occ))
+ (occurrences construct :revision revision))))
+ (remove-if #'null results)))))
+
+
+(defgeneric characteristic-by-type (construct type-identifier &key revision)
+ (:documentation "Returns all characteristics that are of the
+ corresponding type.")
+ (:method ((construct TopicC) (type-identifier IdentifierC)
+ &key (revision *TM-REVISION*))
+ (declare (integer revision))
+ (union (names-by-type construct type-identifier :revision revision)
+ (occurrences-by-type construct type-identifier :revision revision))))
+
+
+(defgeneric occurrences-by-value (construct filter &key revision)
+ (:documentation "Returns a list of all occurrences of the passed
+ topic, that return a true value when calling filter
+ on their charvalue.")
+ (:method ((construct TopicC) (filter Function) &key (revision *TM-REVISION*))
+ (let ((results
+ (map 'list #'(lambda(occ)
+ (when (invoke-on occ filter)
+ occ))
+ (occurrences construct :revision revision))))
+ (remove-if #'null results))))
+
+
+(defgeneric names-by-value (construct filter &key revision)
+ (:documentation "Returns a list of all names of the passed
+ topic, that return a true value when calling filter
+ on their charvalue.")
+ (:method ((construct TopicC) (filter Function) &key (revision *TM-REVISION*))
+ (let ((results
+ (map 'list #'(lambda(name)
+ (when (invoke-on name filter)
+ name))
+ (names construct :revision revision))))
+ (remove-if #'null results))))
+
+
+(defgeneric characteristic-by-value (construct filter &key revision)
+ (:documentation "Returns a list of all characteristics of the passed
+ topic, that return a true value when calling filter.")
+ (:method ((construct TopicC) (filter Function) &key (revision *TM-REVISION*))
+ (declare (integer revision))
+ (union (names-by-value construct filter :revision revision)
+ (occurrences-by-value construct filter :revision revision))))
\ No newline at end of file
More information about the Isidorus-cvs
mailing list