<commit_before>;;;; clorb-ifr.lisp -- An Interface Repository Implementation

(in-package :clorb)


;;;; Registry of Ir class for DefinitionKind

(defun register-ir-class (def-kind class)
  (setf (get def-kind 'ir-class) class))

#+unused-functions
(defun get-ir-class (def-kind)
  (or (get def-kind 'ir-class)
      (error "No class defined for definition kind ~A" def-kind)))


;;;; Generics

(defgeneric moveto (contained container new-name new-version)
  (:documentation "Move the contained object to the container,
with new-name and new-version. Checks that the name does not collied 
with the contents of container and check the container allows the type 
of contained."))



;;;; Base Clases

(defmacro define-ir-class (name supers
                           &rest args
                           &key id def_kind &allow-other-keys)
  (declare (ignore id))
  (setq args
    (loop for x on args by #'cddr
        unless (member (car x) '(:id :def_kind))
        nconc (list (car x) (cadr x))))
  `(progn (define-corba-class ,name ,supers ,@args)
          ,@(if def_kind
                `((define-method def_kind ((x ,name)) ,def_kind)
                  (register-ir-class ,def_kind ',name)))))


(define-ir-class IRObject (CORBA:IRObject)
  :id "IDL:omg.org/CORBA/IRObject:1.0"
  :attributes ()
  :defaults ())


(define-method op:destroy ((obj IRObject))
  nil)


(defclass IRTypeCode-Mixin ()
  ((type)))

(defgeneric idltype-tc (irtypecode-mixin)
  (:documentation
   "Compute the TypeCode from the attributes other than type."))

(define-method type ((def irtypecode-mixin))
  ;; Get the typecode for an IDL construct.
  ;; The typecode is lazily constructed and recursive typecodes handled.
  ;; The specific typcodes are handled by the idltype-tc function.
  (cond ((slot-boundp def 'type)
         ;; Either the typecode is computed already or this is a recursive call
         ;; during computation.
         (let ((tc (slot-value def 'type)))
           (cond ((eq t tc)
                  ;; Beeing computed, make a placeholder typecode.
                  ;; This typecode will be filled when the computation is done.
                  (setf (slot-value def 'type) (make-typecode t)))
                 (t
                  tc))))
        (t
         ;; Typecode not defined, start computation
         ;; mark computation with a t in the slot
         (setf (slot-value def 'type) t)
         (let* ((new-tc (idltype-tc def))
                (old-tc (slot-value def 'type)))
           (cond ((eq old-tc t)
                  (setf (slot-value def 'type) new-tc))
                 (t
                  ;; therse was a recurive access during computation
                  (typecode-smash old-tc new-tc)
                  old-tc))))))


(defmethod slot-updated :after ((obj irtypecode-mixin))
  (slot-makunbound obj 'type))


(define-ir-class IDLType (CORBA:IDLType IRObject irtypecode-mixin)
  :id "IDL:omg.org/CORBA/IDLType:1.0"
  :attributes ()
  :defaults ())



;;;; Contained

(define-ir-class Contained (CORBA:Contained irobject)
  :id "IDL:omg.org/CORBA/Contained:1.0"
  :attributes ((id :readonly            ; setter defined below
                   :initarg :subject-id
                   :accessor subject-id)
               (name "")
               (version "1.0")
               (defined_in nil :readonly)
               ;;(absolute_name "" :readonly)
               (containing_repository :readonly))
  :slots ((absolute_name :initarg :absolute_name)
          (package-prefix :initform "" :accessor package-prefix)))

(defmethod print-object ((obj contained) stream)
  (print-unreadable-object (obj stream :type t :identity t)
    (format stream "~A" (slot-value obj 'name))))

(defmethod (setf op:id) (new-id (obj contained))
  (let ((repository (op:containing_repository obj))
        (old-id (op:id obj)))
    (unless (equal new-id old-id)
      (when (gethash new-id (idmap repository))
        (error (system-exception 'CORBA:BAD_PARAM 2)))
      (remhash old-id (idmap repository))
      (setf (gethash new-id (idmap repository)) obj)
      (setf (slot-value obj 'id) new-id))))

(defmethod (setf op:name) :before (value (obj contained))
  (loop for peer in (contents (op:defined_in obj))
        unless (eq obj peer)
        do (when (string-equal value (op:name peer))
             (raise-system-exception 'CORBA:bad_param 1))))


(define-method absolute_name ((obj contained))
  (unless (and (slot-boundp obj 'absolute_name)
               (not (equal (slot-value obj 'absolute_name)
                           "")))
    (setf (slot-value obj 'absolute_name)
          (concatenate 'string
                       (op:absolute_name (op:defined_in obj)) "::" (op:name obj))))
  (slot-value obj 'absolute_name))

(defmethod slot-updated :after ((obj contained))
  (slot-makunbound obj 'absolute_name))

(define-method describe ((obj contained))
  (CORBA:Contained/Description
   :kind (op:def_kind obj)
   :value (describe-contained obj)))

(define-method "MOVE" ((obj contained) to-container new-name new-version)
  (check-type to-container CORBA:Container)
  (check-type new-name string)
  (check-type new-version string)
  (unless (eql (op:containing_repository obj)
               (op:containing_repository to-container))
    (raise-system-exception 'CORBA:BAD_PARAM 4))
  (moveto to-container obj new-name new-version))

(define-method op:destroy ((obj contained))
  (remhash (subject-id obj) (idmap (op:containing_repository obj)))
  (let ((container (op:defined_in obj)))
    (when container
      (setf (contents container)
            (delete obj (contents container))))))




;;;; Container

(define-ir-class Container (CORBA:Container irobject)
  :id "IDL:omg.org/CORBA/Container:1.0"
  :slots ((contents :initarg :contents
                    :initform '()
                    :accessor contents))
  :defaults ())


(defmethod slot-updated :after ((obj Container))
  (dolist (c (contents obj)) (slot-updated c)))


(defun addto (container object)
  "Add a contained object to a container"
  (let ((repository (op:containing_repository container))
        (id (op:id object)))
    ;; A BAD_PARAM exception is raised with minor code 2 if an object with
    ;; the specified id already exists in the Repository.
    (when (gethash id (idmap repository))
      (raise-system-exception 'CORBA:BAD_PARAM 2))
    (moveto container object (op:name object) (op:version object))
    (setf (gethash id (idmap repository)) object)))


(defmethod moveto ((c container) (object contained) new-name new-version)
  ;; A BAD_PARAM exception with minor code 3 is raised if the specified
  ;; name already exists within this Container and multiple versions are
  ;; not supported.
  (when (member new-name (contents c) :key #'op:name :test #'string-equal)
    (raise-system-exception 'CORBA:bad_param 3))
  (with-slots (defined_in containing_repository name version) 
              object
    (let ((old-container defined_in))
      (when old-container
        (setf (contents old-container) (delete object (contents old-container)))))
    (setf (contents c) (nconc (contents c) (list object)))
    (setf containing_repository (op:containing_repository c))
    (setf defined_in c)
    (setf name new-name)
    (setf version new-version)
    (slot-updated object))
  object)


(define-method contents ((obj container) limit-type exclude-inherit)
  (declare (ignore exclude-inherit))
  ;; exclude-inherit only aplicable for operations???
  (loop for contained in (contents obj)
      when (and (or (eql limit-type :dk_all)
                    (eql limit-type (op:def_kind contained))))
      collect contained))

(define-method lookup_name
    ((obj container) search-name levels-to-search limit-type exclude-inherit)
  (loop for contained in (op:contents obj limit-type exclude-inherit)
      when (equal search-name (op:name contained))
      collect contained into top-level
      when (and (containerp contained)
                (or (> levels-to-search 1) (= levels-to-search -1)))
      collect (op:lookup_name contained search-name
                              (if (= levels-to-search -1)
                                -1
                                (1- levels-to-search))
                              limit-type exclude-inherit)
      into sub-levels
      finally (return (mapcan #'identity (cons top-level sub-levels)))))

(defgeneric containerp (x)
  (:method ((x t)) nil)
  (:method ((x container)) t))


(define-method lookup ((obj null) search_name)
  (declare (ignore search_name))
  nil)

(define-method lookup ((obj container) search_name)
  (cond ((string-starts-with search_name "::")
         (op:lookup (op:containing_repository obj)
                    (subseq search_name 2)))
        (t
         (multiple-value-bind (first-name rest-name)
                              (split-name search_name)
           (let ((contained
                  (find first-name (op:contents obj :dk_all nil)
                        :key #'op:name
                        :test #'string-equal)))
             (cond ((null contained)
                    (op:lookup (op:defined_in obj) search_name))
                   (rest-name
                    (op:lookup contained rest-name))
                   (t
                    contained)))))))

(defun split-name (str)
  (let ((method-end (position #\: str)))
    (if method-end
      (values (subseq str 0 method-end)
              (subseq str (+ method-end 2)))
      str )))


(define-method op:describe_contents ((self container) limit-type exclude-inherited max-return-objects)
  (when (eql max-return-objects -1)
    (setq max-return-objects most-positive-fixnum))
  (loop for c in (op:contents self limit-type exclude-inherited)
        repeat max-return-objects
        collect (CORBA:Container/Description 
                 :contained_object c
                 :kind (op:def_kind c)
                 :value (describe-contained c))))


;;;  ModuleDef create_module (
;;;                           in RepositoryId id,
;;;                           in Identifier name,
;;;                           in VersionSpec version

(define-method create_module ((self container) id name version)
  (addto self (make-instance 'module-def
                :id id :name name :version version)))


;;;  ConstantDef create_constant (
;;;                               in RepositoryId id,
;;;                               in Identifier name,
;;;                               in VersionSpec version,
;;;                               in IDLType type,
;;;                               in any value                  )

(define-method create_constant ((self container)
                                id name version type value)
  (addto self (make-instance 'constant-def
                :id id :name name :version version
                :type_def type :value value)))

;;;  StructDef create_struct (
;;;                           in RepositoryId id,
;;;                           in Identifier name,
;;;                           in VersionSpec version,
;;;                           in StructMemberSeq members

(define-method create_struct ((self container)
                              id name version members)
  (let ((obj (make-instance 'struct-def
               :id id :name name :version version)))
    (setf (op:members obj) members)
    (addto self obj)))


;;;  /* This operation is missing in the CORBA2 spec! */
;;;  ExceptionDef create_exception (
;;;                                 in RepositoryId id,
;;;                                 in Identifier name,
;;;                                 in VersionSpec version,
;;;                                 in StructMemberSeq members
;;;                                 );

(define-method create_exception ((self container)
                                 id name version members)
  (addto self (make-instance 'exception-def
                :id id
                :name name
                :version version
                :members members)))



;;;  UnionDef create_union (
;;;                         in RepositoryId id,
;;;                         in Identifier name,
;;;                         in VersionSpec version,
;;;                         in IDLType discriminator_type,
;;;                         in UnionMemberSeq members           );

(define-method create_union ((self container)
                             id name version discriminator_type members)
  (check-type discriminator_type CORBA:IDLType)
  (assert (and (typep members 'sequence)
               (every (lambda (x) (typep x 'CORBA:UnionMember))
                      members))
          (members)
          'type-error :datum 'members :expected-type 'corba:unionmemberseq)
  (addto self (make-instance 'union-def
                :id id :name name :version version
                :discriminator_type_def discriminator_type
                :members members)))


;;;  EnumDef create_enum (
;;;                       in RepositoryId id,
;;;                       in Identifier name,
;;;                       in VersionSpec version,
;;;                       in EnumMemberSeq members
;;;                       );

(define-method create_enum ((self container)
                              id name version members)
  (addto self (make-instance 'enum-def
                :id id :name name :version version
                :members members)))


;;;  AliasDef create_alias (
;;;                         in RepositoryId id,
;;;                         in Identifier name,
;;;                         in VersionSpec version,
;;;                         in IDLType original_type    );

(define-method create_alias ((self container)
                             id name version original_type)
  (addto self (make-instance 'alias-def
                :id id :name name :version version
                :original_type_def original_type)))


;;;  InterfaceDef create_interface (
;;;            in RepositoryId id,
;;;            in Identifier name,
;;;            in VersionSpec version,
;;;            in InterfaceDefSeq base_interfaces );

(define-method create_interface ((self container)
                                 id name version base_interfaces)
  (addto self (make-instance 'interface-def
                :id id :name name :version version
                :base_interfaces base_interfaces)))


;;;    ValueBoxDef create_value_box(
;;;                                 in RepositoryId id,
;;;                                 in Identifier name,
;;;                                 in VersionSpec version,
;;;                                 in IDLType original_type_def

(define-method create_value_box ((self container)
                                 id name version original_type_def)
  (addto self (make-instance 'valuebox-def
                :id id :name name :version version
                :original_type_def original_type_def)))

;;;    NativeDef create_native(
;;;                            in RepositoryId id,
;;;                            in Identifier name,
;;;                            in VersionSpec version

(define-method create_native ((self container) id name version )
  (addto self (make-instance 'native-def
                :id id :name name :version version )))

;;;    AbstractInterfaceDef create_abstract_interface(
;;;                                          in RepositoryId id,
;;;                                          in Identifier name,
;;;                                          in VersionSpec version,
;;;                                          in AbstractInterfaceDefSeq base_interfaces

(define-method create_abstract_interface ((self container)
                                 id name version base_interfaces)
  (addto self (make-instance 'abstractinterface-def
                :id id :name name :version version
                :base_interfaces base_interfaces)))
		
;;;    LocalInterfaceDef create_local_interface(
;;;                                             in RepositoryId id,
;;;                                             in Identifier name,
;;;                                             in VersionSpec version,
;;;                                             in InterfaceDefSeq base_interfaces

(define-method create_local_interface ((self container)
                                 id name version base_interfaces)
  (addto self (make-instance 'localinterface-def
                :id id :name name :version version
                :base_interfaces base_interfaces)))


;;; ValueDef create_value

(define-method create_value ((self container)
                              id name version is_custom is_abstract
                              base_value is_truncatable abstract_base_values
                              supported_interfaces initializers)
  (check-type id CORBA:RepositoryId)
  (check-type name CORBA:Identifier)
  (check-type version CORBA:VersionSpec)
  (check-type is_custom CORBA:boolean)
  (check-type is_abstract CORBA:boolean)
  (check-type base_value (or null CORBA:ValueDef))
  (check-type is_truncatable CORBA:boolean)
  (check-type abstract_base_values CORBA:ValueDefSeq)
  (check-type supported_interfaces CORBA:InterfaceDefSeq)
  (check-type initializers CORBA:InitializerSeq)
  (addto self (make-instance 'value-def
                :id id :name name :version version
                :is_custom is_custom  :is_abstract is_abstract
                :base_value base_value :is_truncatable is_truncatable
                :abstract_base_values abstract_base_values
                :supported_interfaces supported_interfaces
                :initializers initializers)))


(define-method op:destroy ((obj container))
  (dolist (x (contents obj))
    (op:destroy x))
  (call-next-method))

		


;;;; Repository

;;; interface Repository : Container

(define-ir-class Repository (CORBA:Repository Container)
  :id "IDL:omg.org/CORBA/Repository:1.0"
  :def_kind :dk_repository
  :slots ((idmap :initform (make-hash-table :test #'equal)
                 :reader idmap)
          (primitives-cache
           :initform nil
           :accessor primitives-cache )))


;;; Method to simplify computation of absolute_name
(define-method absolute_name ((obj Repository))
  "")

(define-method containing_repository ((r Repository))
  r)

(defmethod subject-id ((r repository))
  "")

;;;  Contained lookup_id (in RepositoryId search_id);

(define-method lookup_id ((rep repository) id)
  (gethash id (idmap rep)))


;;; TypeCode get_canonical_typecode(in TypeCode tc);

(define-method get_canonical_typecode ((container Repository) tc)
  (flet ((reconstruct ()
           (map-typecode (lambda (tc) (op:get_canonical_typecode container tc))
                         tc)))
    (handler-case
      (let ((id (op:id tc)))
        (let ((obj (op:lookup_id container id)))
          (if obj
            (op:type obj)
            (reconstruct))))
      (CORBA:TYPECODE/BADKIND () (reconstruct)))))



;;;  PrimitiveDef get_primitive (in PrimitiveKind kind);

(define-method get_primitive ((container Repository) kind)
  (with-accessors ((cache primitives-cache)) container
    (unless cache
      (setf cache
            (loop for (kind tc) 
                  in '((:pk_null CORBA:tc_null)
                       (:pk_void CORBA:tc_void)
                       (:pk_short CORBA:tc_short)
                       (:pk_long CORBA:tc_long)
                       (:pk_ushort CORBA:tc_ushort)
                       (:pk_ulong CORBA:tc_ulong)
                       (:pk_float CORBA:tc_float)
                       (:pk_double CORBA:tc_double)
                       (:pk_boolean CORBA:tc_boolean)
                       (:pk_char CORBA:tc_char)
                       (:pk_octet CORBA:tc_octet)
                       (:pk_any CORBA:tc_any)
                       (:pk_typecode CORBA:tc_TypeCode)
                       ;;(:pk_Principal CORBA:tc_Principal)
                       (:pk_string CORBA:tc_string)
                       (:pk_objref CORBA:tc_object)
                       (:pk_longlong CORBA:tc_longlong)
                       (:pk_ulonglong CORBA:tc_ulonglong)
                       (:pk_longdouble CORBA:tc_longdouble)
                       (:pk_wchar CORBA:tc_wchar)
                       (:pk_wstring CORBA:tc_wstring)
                       (:pk_value_base corba:tc_valuebase))
                  collect (make-instance 'primitive-def :kind kind 
                                         :type (symbol-value tc)))))
    (find kind cache :key #'op:kind)))


;;;  StringDef create_string (in unsigned long bound);

(define-method create_string ((container Repository) bound)
  (make-instance 'string-def
    :bound bound))

;;;  WstringDef create_wstring (in unsigned long bound);

(define-method create_wstring ((container Repository) bound)
  (make-instance 'wstring-def
    :bound bound))


;;;  SequenceDef create_sequence
;;;     (in unsigned long bound,in IDLType element_type);

(define-method create_sequence ((container Repository) bound element-type)
  (check-type bound integer)
  (check-type element-type corba:idltype)
  (make-instance 'sequence-def
    :bound bound
    :element_type_def element-type))


;;;  ArrayDef create_array
;;;     (in unsigned long length,in IDLType element_type);

(define-method create_array ((container Repository) length element_type)
  (make-instance 'array-def
    :length length
    :element_type_def element_type))


;;;  FixedDef create_fixed
;;;     (in unsigned short digits,in short scale);

(define-method create_fixed ((container Repository) digits scale)
  (make-instance 'fixed-def
    :digits digits
    :scale scale))


(define-method op:destroy ((obj repository))
  (raise-system-exception 'omg.org/corba:bad_inv_order
                          2 :completed_yes))




;;;; ModuleDef

(define-ir-class module-def (CORBA:ModuleDef container contained)
  :id "IDL:omg.org/CORBA/ModuleDef:1.0"
  :def_kind :dk_module
  :defaults ())


(defmethod describe-contained ((module module-def))
  (CORBA:ModuleDescription
   :name (op:name module)
   :id (op:id module)
   :defined_in (or (op:defined_in module) "")
   :version (op:version module)))


;;;; interface ConstantDef : Contained {
;;;   readonly attribute TypeCode type;
;;;   attribute IDLType type_def;
;;;   attribute any value; };

(define-ir-class constant-def (CORBA:ConstantDef contained)
  :id "IDL:omg.org/CORBA/ConstantDef:1.0"
  :attributes ((type_def)
               (value))
  :def_kind :dk_constant)

(define-method type ((obj constant-def))
  (op:type (op:type_def obj)))



;;;; InterfaceDef

(define-ir-class interface-def (CORBA:InterfaceDef container contained idltype)
  :def_kind :dk_interface 
  :attributes ((base_interfaces)))

(defmethod idltype-tc ((idef interface-def))
  (create-interface-tc (subject-id idef) (op:name idef)))

(define-method is_a ((def interface-def) interface-id)
  (or
   (equal (subject-id def) interface-id)
   (equal interface-id (symbol-ifr-id 'corba:object))
   (some (lambda (b) (equal interface-id (op:id b)))
         (op:base_interfaces def))))

(define-method describe_interface ((def interface-def))
  (CORBA:InterfaceDef/FullInterfaceDescription
   :name (op:name def)
   :id   (subject-id def)
   :defined_in (subject-id (op:defined_in def))
   :version (op:version def)
   :operations (map 'list #'operation-description
                    (op:contents def :dk_operation nil))
   :attributes (map 'list #'describe-contained
                    (op:contents def :dk_attribute nil))
   :base_interfaces (map 'list #'subject-id (op:base_interfaces def))
   :type (op:type def) ))

(defmethod describe-contained ((def interface-def))
  (CORBA:InterfaceDescription
   :name (op:name def)
   :id   (subject-id def)
   :defined_in (subject-id (op:defined_in def))
   :version (op:version def)
   :base_interfaces (map 'list #'subject-id (op:base_interfaces def))))

(define-method contents ((obj interface-def) limit-type exclude-inherit)
  (if exclude-inherit
      (call-next-method)
    (append (call-next-method)
            (loop for x in (coerce (op:base_interfaces obj) 'list)
                append (op:contents x limit-type nil)))))


(defun check-unique-name (container name &key (minor 3))
  (when (op:lookup_name container name 1 :dk_all nil)
    (raise-system-exception 'CORBA:bad_param minor)))

(define-method (setf op:base_interfaces) :before (value (self interface-def))
  (loop for obj in (contents self) do
        (loop for base in value do
              (check-unique-name base (op:name obj) :minor 5))))


;;;  AttributeDef create_attribute

(define-method create_attribute ((self interface-def)
                                 id name version type mode)
  (check-type id string)                ; RepositoryId
  (check-type name string)              ; Identifier
  (check-type version string)           ; VersionSpec
  (check-type type IDLType)
  (check-type mode CORBA:AttributeMode)
  (check-unique-name self name)
  (addto self (make-instance 'attribute-def
                :id id :name name :version version
                :type_def type :mode mode)))


;;;  OperationDef create_operation

(define-method create_operation ((self interface-def)
                                 id name version
                                 result mode params exceptions contexts)
  (check-type id string)                ; RepositoryId
  (check-type name string)              ; Identifier
  (check-type version string)           ; VersionSpec
  (check-type result IDLType)
  (check-type mode CORBA:OperationMode)
  (check-type params CORBA:ParDescriptionSeq)
  (check-type exceptions CORBA:ExceptionDefSeq)
  (check-type contexts CORBA:ContextIdSeq)
  (check-unique-name self name)
  (addto self (make-instance 'operation-def
                :id id :name name :version version
                :result_def result :mode mode
                :params params :exceptions exceptions
                :contexts contexts)))



;;;; AttributeDef

(define-ir-class attribute-def (CORBA:AttributeDef contained)
  :id "IDL:omg.org/CORBA/AttributeDef:1.0"
  :attributes ((type_def)
               (mode))
  :def_kind :dk_attribute
  :defaults ())

(define-method type ((adef attribute-def))
  (op:type (op:type_def adef)))

(defmethod describe-contained ((adef attribute-def))
  (CORBA:AttributeDescription
   ;; Identifier name
   :name (op:name adef)
   ;; RepositoryId id
   :id (op:id adef)
   ;; RepositoryId defined_in
   :defined_in (subject-id (op:defined_in adef))
   ;; VersionSpec version
   :version (op:version adef)
   ;; TypeCode type
   :type (op:type adef)
   ;; AttributeMode mode
   :mode (op:mode adef)))



;;;; OperationDef

(define-ir-class operation-def (CORBA:OperationDef contained)
  :id "IDL:omg.org/CORBA/OperationDef:1.0"
  :attributes ((result :readonly :virtual result)
               (result_def)
               (params nil)
               (mode ':op_normal)
               (contexts nil)
               (exceptions nil))
  :def_kind :dk_operation )

(defun validate-operation-def (mode result params exceptions)
  (when (eq mode :op_oneway)
    (unless (and (eq :tk_void (op:kind (op:type result)))
                 (zerop (length exceptions))
                 (every (lambda (p)
                          (eq :param_in (op:mode p)))
                        params))
      (raise-system-exception 'CORBA:bad_param 31 :completed_yes))))

(defun validate-operation-def-change (def &key 
                                            (mode (op:mode def))
                                            (result (op:result_def def))
                                            (params (slot-value def 'params))
                                            (exceptions (op:exceptions def)))
  (validate-operation-def mode result params exceptions))

(defmethod initialize-instance :before ((def operation-def)
                                        &key result_def mode params exceptions)
  (validate-operation-def mode result_def params exceptions))

(defmethod (setf op:result_def) :before (new (def operation-def)) 
  (validate-operation-def-change def :result new))

(defmethod (setf op:mode) :before (new (def operation-def))
  (validate-operation-def-change def :mode new))               

(defmethod (setf op:params) :before (new (def operation-def))
  (validate-operation-def-change def :params new))               

(defmethod (setf op:exceptions) :before (new (def operation-def))
  (validate-operation-def-change def :exceptions new))               

(defmethod result ((opdef operation-def))
  (op:type (slot-value opdef 'result_def)))

(defmethod op:params :before ((opdef operation-def) &key)
  (doseq (pd (slot-value opdef 'params))
         (setf (op:type pd) (op:type (op:type_def pd)))))


(defmethod opdef-inparam-typecodes ((opdef operation-def))
  (loop for param in (op:params opdef)
      unless (eq (op:mode param) :param_out)
      collect (op:type param)))

#+unused-defuns
(defmethod opdef-outparam-typecodes ((opdef operation-def))
  (let ((real-params
         (loop for param in (op:params opdef)
             unless (eq (op:mode param) :param_in)
             collect (op:type param)))
        (result (op:result opdef)))
    (if (eq :tk_void (typecode-kind result))
        real-params
      (cons result real-params))))




(defun operation-description (opdef)
  ;;  struct OperationDescription
  (CORBA:OperationDescription
   ;;  Identifier name;
   :name (op:name opdef)
   ;;  RepositoryId id;
   :id   (op:id opdef)
   ;;  RepositoryId defined_in;
   :defined_in (op:id (op:defined_in opdef))
   ;;  VersionSpec version;
   :version (op:version opdef)
   ;;  TypeCode result;
   :result (op:result opdef)
   ;;  OperationMode mode;
   :mode (op:mode opdef)
   ;;  ContextIdSeq contexts;
   :contexts (op:contexts opdef)
   ;;  ParDescriptionSeq parameters;
   :parameters (op:params opdef)
   ;;  ExcDescriptionSeq exceptions;
   :exceptions (map 'list
                    'describe-contained (op:exceptions opdef))))

(defmethod describe-contained ((obj operation-def))
  (operation-description obj))


;;;; TypedefDef

(define-ir-class typedef-def (CORBA:TypedefDef contained idltype)
  :id "IDL:omg.org/CORBA/TypedefDef:1.0"
  :def_kind :dk_typedef
  :defaults ())

(defmethod describe-contained ((obj typedef-def))
  (CORBA:TypeDescription
   ;; Identifier name
   :name (op:name obj)
   ;; RepositoryId id
   :id (op:id obj)
   ;; RepositoryId defined_in
   :defined_in (subject-id (op:defined_in obj))
   ;; VersionSpec version
   :version (op:version obj)
   ;; TypeCode type
   :type (op:type obj)))


;;;; interface AliasDef : TypedefDef
;;  attribute IDLType original_type_def;

(define-ir-class alias-def (corba:AliasDef typedef-def)
  :id "IDL:omg.org/CORBA/AliasDef:1.0"
  :attributes ((original_type_def))
  :def_kind :dk_alias
  :defaults ())

(defmethod idltype-tc ((def alias-def))
  (create-alias-tc (op:id def) (op:name def)
                   (op:type (op:original_type_def def))))

(define-method op:destroy ((obj alias-def))
  (let ((orig (op:original_type_def obj)))
    (when (and (typep orig 'CORBA:IDLtype)
               (typep orig 'CORBA:Contained))
      (op:destroy orig)))
  (call-next-method))





;;;; interface StructDef : TypedefDef
;; attribute StructMemberSeq members;
;; struct StructMember {
;;  Identifier name;
;;  TypeCode type;
;;  IDLType type_def;

(define-ir-class struct-def (corba:StructDef typedef-def container)
  :id "IDL:omg.org/CORBA/StructDef:1.0"
  :def_kind :dk_struct
  :attributes ((members)))


(defmethod moveto :before ((c struct-def) (object contained) new-name new-version)
  (declare (ignore new-name new-version))
  (typecase object 
    ((or Struct-Def Union-Def Enum-Def))
    (otherwise
     (raise-system-exception 'CORBA:BAD_PARAM 4))))


(defmethod op:members :before ((obj struct-def) &rest x)
  (declare (ignore x))
  (doseq (m (slot-value obj 'members))
    (setf (op:type m) (op:type (op:type_def m)))))


(defmethod idltype-tc ((def struct-def))
  (create-struct-tc (op:id def) (op:name def) (simple-struct-members (op:members def))))



;;;; interface UnionDef : TypedefDef
;;;   readonly attribute TypeCode discriminator_type;
;;;   attribute IDLType discriminator_type_def;
;;;   attribute UnionMemberSeq members;

;;; struct UnionMember {
;;;   Identifier name;
;;;   any label;
;;;   TypeCode type;
;;;   IDLType type_def;
;;; typedef sequence <UnionMember> UnionMemberSeq;

(define-ir-class union-def (CORBA:UnionDef typedef-def container)
  :id "IDL:omg.org/CORBA/UnionDef:1.0"
  :attributes ((discriminator_type_def)
               (members))
  :def_kind :dk_union)

(defmethod moveto :before ((c union-def) (object contained) new-name new-version)
  (declare (ignore new-name new-version))
  (typecase object 
    ((or Struct-Def Union-Def Enum-Def))
    (otherwise
     (raise-system-exception 'CORBA:BAD_PARAM 4))))

(define-method discriminator_type ((obj union-def))
  (op:type (op:discriminator_type_def obj)))

(defmethod op:members :before ((self union-def) &rest args)
  (declare (ignore args))
  (doseq (member (slot-value self 'members))
    (setf (op:type member) (op:type (op:type_def member)))))

(defmethod idltype-tc ((obj union-def))
  ;; FIXME: should be simpler to use op:create_union_tc
  (flet ((default-label-p (label)
           (and (not (symbolp label))
                (eql :tk_octet (op:kind (any-typecode label)))
                (= 0 (any-value label)))))
    (create-union-tc (op:id obj) (op:name obj)
                     (op:discriminator_type obj)
                     (map 'list (lambda (m)
                                  (list (if (default-label-p (op:label m))
                                          'default
                                          (op:label m))
                                        (op:name m)
                                        (op:type m)))
                          (op:members obj)))))



;;;; EnumDef

(define-ir-class enum-def (corba:EnumDef typedef-def)
  :id "IDL:omg.org/CORBA/EnumDef:1.0"
  :attributes ((members))
  :def_kind :dk_enum
  :defaults ())

(defmethod idltype-tc ((obj enum-def))
  (create-enum-tc (op:id obj) (op:name obj) (op:members obj)))


;;;; interface ExceptionDef : Contained
;;;  readonly attribute TypeCode type;
;;;  attribute StructMemberSeq members;

(define-ir-class exception-def (corba:ExceptionDef contained container irtypecode-mixin)
  :id "IDL:omg.org/CORBA/ExceptionDef:1.0"
  :def_kind :dk_exception
  :attributes ((members)))


(defmethod moveto :before ((c exception-def) (object contained) new-name new-version)
  (declare (ignore new-name new-version))
  (typecase object 
    ((or Struct-Def Union-Def Enum-Def))
    (otherwise
     (raise-system-exception 'CORBA:BAD_PARAM 4))))


(defmethod op:members :before ((obj exception-def) &rest x)
  (declare (ignore x))
  (doseq (m (slot-value obj 'members))
    (setf (op:type m) (op:type (op:type_def m)))))


(defmethod idltype-tc ((obj exception-def))
  (create-exception-tc (op:id obj) (op:name obj)
                       (simple-struct-members (op:members obj))))


(defmethod describe-contained ((obj exception-def))
  (CORBA:ExceptionDescription
   ;;  Identifier name;
   :name (op:name obj)
   ;;  RepositoryId id;
   :id (op:id obj)
   ;;  RepositoryId defined_in;
   :defined_in (subject-id (op:defined_in obj))
   ;;  VersionSpec version;
   :version (op:version obj)
   ;;  TypeCode type;
   :type (op:type obj)))



;;;; PrimitiveDef

(define-ir-class primitive-def (corba:PrimitiveDef idltype)
  :id "IDL:omg.org/CORBA/PrimitiveDef:1.0"
  :attributes ((kind))
  :def_kind :dk_primitive
  :slots ((type :initarg :type)) ; add initarg
  :defaults ())

(defmethod print-object ((obj primitive-def) stream)
  (print-unreadable-object (obj stream :type t :identity t)
    (format stream "~A" (slot-value obj 'kind))))

(define-method op:destroy ((obj primitive-def))
  (raise-system-exception 'omg.org/corba:bad_inv_order
                          2 :completed_yes))



;;;; interface StringDef : IDLType
;;;  attribute unsigned long bound;

(define-ir-class string-def (corba:StringDef idltype)
  :id "IDL:omg.org/CORBA/StringDef:1.0"
  :attributes ((bound 0))
  :def_kind :dk_string)

(defmethod idltype-tc ((obj string-def))
  (create-string-tc (op:bound obj)))



;;;; interface WstringDef : IDLType
;;;  attribute unsigned long bound;

(define-ir-class wstring-def (corba:WstringDef idltype)
  :id "IDL:omg.org/CORBA/WstringDef:1.0"
  :attributes ((bound 0))
  :def_kind :dk_wstring)

(defmethod idltype-tc ((obj wstring-def))
  (create-wstring-tc (op:bound obj)))


;;;; SequenceDef
;;interface SequenceDef : IDLType
;;  attribute unsigned long bound;
;;  readonly attribute TypeCode element_type;
;;  attribute IDLType element_type_def;

(define-ir-class sequence-def (corba:SequenceDef IDLType)
  :id "IDL:omg.org/CORBA/SequenceDef:1.0"
  :def_kind :dk_sequence
  :attributes ((bound 0)                  ; long
               ;;(element_type :readonly) ; TypeCode
               (element_type_def))      ; IDLType
  :defaults ())

(define-method element_type ((obj sequence-def))
  (op:type (op:element_type_def obj)))

(defmethod idltype-tc ((obj sequence-def))
  (create-sequence-tc (op:bound obj) (op:element_type obj)))



;;;; ArrayDef : IDLType
;;        attribute unsigned long         length;
;;        readonly attribute TypeCode     element_type;
;;        attribute IDLType               element_type_def;

(define-ir-class array-def (CORBA:ArrayDef idltype)
  :id "IDL:omg.org/CORBA/ArrayDef:1.0"
  :def_kind :dk_array
  :attributes ((length 0)
               (element_type_def)))

(define-method element_type ((obj array-def))
  (op:type (op:element_type_def obj)))
<commit_msg>IFR cleanup, removing obsolte ids<commit_after>;;;; clorb-ifr.lisp -- An Interface Repository Implementation

(in-package :clorb)


;;;; Registry of Ir class for DefinitionKind

(defun register-ir-class (def-kind class)
  (setf (get def-kind 'ir-class) class))

#+unused-functions
(defun get-ir-class (def-kind)
  (or (get def-kind 'ir-class)
      (error "No class defined for definition kind ~A" def-kind)))


;;;; Generics

(defgeneric moveto (contained container new-name new-version)
  (:documentation "Move the contained object to the container,
with new-name and new-version. Checks that the name does not collied 
with the contents of container and check the container allows the type 
of contained."))



;;;; Base Clases

(defmacro define-ir-class (name supers
                           &rest args
                           &key id def_kind &allow-other-keys)
  (declare (ignore id))
  (setq args
    (loop for x on args by #'cddr
        unless (member (car x) '(:id :def_kind))
        nconc (list (car x) (cadr x))))
  `(progn (define-corba-class ,name ,supers ,@args)
          ,@(if def_kind
                `((define-method def_kind ((x ,name)) ,def_kind)
                  (register-ir-class ,def_kind ',name)))))


(define-ir-class IRObject (CORBA:IRObject)
  :id "IDL:omg.org/CORBA/IRObject:1.0"
  :attributes ()
  :defaults ())


(define-method op:destroy ((obj IRObject))
  nil)


(defclass IRTypeCode-Mixin ()
  ((type)))

(defgeneric idltype-tc (irtypecode-mixin)
  (:documentation
   "Compute the TypeCode from the attributes other than type."))

(define-method type ((def irtypecode-mixin))
  ;; Get the typecode for an IDL construct.
  ;; The typecode is lazily constructed and recursive typecodes handled.
  ;; The specific typcodes are handled by the idltype-tc function.
  (cond ((slot-boundp def 'type)
         ;; Either the typecode is computed already or this is a recursive call
         ;; during computation.
         (let ((tc (slot-value def 'type)))
           (cond ((eq t tc)
                  ;; Beeing computed, make a placeholder typecode.
                  ;; This typecode will be filled when the computation is done.
                  (setf (slot-value def 'type) (make-typecode t)))
                 (t
                  tc))))
        (t
         ;; Typecode not defined, start computation
         ;; mark computation with a t in the slot
         (setf (slot-value def 'type) t)
         (let* ((new-tc (idltype-tc def))
                (old-tc (slot-value def 'type)))
           (cond ((eq old-tc t)
                  (setf (slot-value def 'type) new-tc))
                 (t
                  ;; therse was a recurive access during computation
                  (typecode-smash old-tc new-tc)
                  old-tc))))))


(defmethod slot-updated :after ((obj irtypecode-mixin))
  (slot-makunbound obj 'type))


(define-ir-class IDLType (CORBA:IDLType IRObject irtypecode-mixin)
  :id "IDL:omg.org/CORBA/IDLType:1.0"
  :attributes ()
  :defaults ())



;;;; Contained

(define-ir-class Contained (CORBA:Contained irobject)
  :attributes ((id :readonly            ; setter defined below
                   :initarg :subject-id
                   :accessor subject-id)
               (name "")
               (version "1.0")
               (defined_in nil :readonly)
               ;;(absolute_name "" :readonly)
               (containing_repository :readonly))
  :slots ((absolute_name :initarg :absolute_name)
          (package-prefix :initform "" :accessor package-prefix)))

(defmethod print-object ((obj contained) stream)
  (print-unreadable-object (obj stream :type t :identity t)
    (format stream "~A" (slot-value obj 'name))))

(defmethod (setf op:id) (new-id (obj contained))
  (let ((repository (op:containing_repository obj))
        (old-id (op:id obj)))
    (unless (equal new-id old-id)
      (when (gethash new-id (idmap repository))
        (error (system-exception 'CORBA:BAD_PARAM 2)))
      (remhash old-id (idmap repository))
      (setf (gethash new-id (idmap repository)) obj)
      (setf (slot-value obj 'id) new-id))))

(defmethod (setf op:name) :before (value (obj contained))
  (loop for peer in (contents (op:defined_in obj))
        unless (eq obj peer)
        do (when (string-equal value (op:name peer))
             (raise-system-exception 'CORBA:bad_param 1))))


(define-method absolute_name ((obj contained))
  (unless (and (slot-boundp obj 'absolute_name)
               (not (equal (slot-value obj 'absolute_name)
                           "")))
    (setf (slot-value obj 'absolute_name)
          (concatenate 'string
                       (op:absolute_name (op:defined_in obj)) "::" (op:name obj))))
  (slot-value obj 'absolute_name))

(defmethod slot-updated :after ((obj contained))
  (slot-makunbound obj 'absolute_name))

(define-method describe ((obj contained))
  (CORBA:Contained/Description
   :kind (op:def_kind obj)
   :value (describe-contained obj)))

(define-method "MOVE" ((obj contained) to-container new-name new-version)
  (check-type to-container CORBA:Container)
  (check-type new-name string)
  (check-type new-version string)
  (unless (eql (op:containing_repository obj)
               (op:containing_repository to-container))
    (raise-system-exception 'CORBA:BAD_PARAM 4))
  (moveto to-container obj new-name new-version))

(define-method op:destroy ((obj contained))
  (remhash (subject-id obj) (idmap (op:containing_repository obj)))
  (let ((container (op:defined_in obj)))
    (when container
      (setf (contents container)
            (delete obj (contents container))))))




;;;; Container

(define-ir-class Container (CORBA:Container irobject)
  :slots ((contents :initarg :contents
                    :initform '()
                    :accessor contents)))


(defmethod slot-updated :after ((obj Container))
  (dolist (c (contents obj)) (slot-updated c)))


(defun addto (container object)
  "Add a contained object to a container"
  (let ((repository (op:containing_repository container))
        (id (op:id object)))
    ;; A BAD_PARAM exception is raised with minor code 2 if an object with
    ;; the specified id already exists in the Repository.
    (when (gethash id (idmap repository))
      (raise-system-exception 'CORBA:BAD_PARAM 2))
    (moveto container object (op:name object) (op:version object))
    (setf (gethash id (idmap repository)) object)))


(defmethod moveto ((c container) (object contained) new-name new-version)
  ;; A BAD_PARAM exception with minor code 3 is raised if the specified
  ;; name already exists within this Container and multiple versions are
  ;; not supported.
  (when (member new-name (contents c) :key #'op:name :test #'string-equal)
    (raise-system-exception 'CORBA:bad_param 3))
  (with-slots (defined_in containing_repository name version) 
              object
    (let ((old-container defined_in))
      (when old-container
        (setf (contents old-container) (delete object (contents old-container)))))
    (setf (contents c) (nconc (contents c) (list object)))
    (setf containing_repository (op:containing_repository c))
    (setf defined_in c)
    (setf name new-name)
    (setf version new-version)
    (slot-updated object))
  object)


(define-method contents ((obj container) limit-type exclude-inherit)
  (declare (ignore exclude-inherit))
  ;; exclude-inherit only aplicable for operations???
  (loop for contained in (contents obj)
      when (and (or (eql limit-type :dk_all)
                    (eql limit-type (op:def_kind contained))))
      collect contained))

(define-method lookup_name
    ((obj container) search-name levels-to-search limit-type exclude-inherit)
  (loop for contained in (op:contents obj limit-type exclude-inherit)
      when (equal search-name (op:name contained))
      collect contained into top-level
      when (and (containerp contained)
                (or (> levels-to-search 1) (= levels-to-search -1)))
      collect (op:lookup_name contained search-name
                              (if (= levels-to-search -1)
                                -1
                                (1- levels-to-search))
                              limit-type exclude-inherit)
      into sub-levels
      finally (return (mapcan #'identity (cons top-level sub-levels)))))

(defgeneric containerp (x)
  (:method ((x t)) nil)
  (:method ((x container)) t))


(define-method lookup ((obj null) search_name)
  (declare (ignore search_name))
  nil)

(define-method lookup ((obj container) search_name)
  (cond ((string-starts-with search_name "::")
         (op:lookup (op:containing_repository obj)
                    (subseq search_name 2)))
        (t
         (multiple-value-bind (first-name rest-name)
                              (split-name search_name)
           (let ((contained
                  (find first-name (op:contents obj :dk_all nil)
                        :key #'op:name
                        :test #'string-equal)))
             (cond ((null contained)
                    (op:lookup (op:defined_in obj) search_name))
                   (rest-name
                    (op:lookup contained rest-name))
                   (t
                    contained)))))))

(defun split-name (str)
  (let ((method-end (position #\: str)))
    (if method-end
      (values (subseq str 0 method-end)
              (subseq str (+ method-end 2)))
      str )))


(define-method op:describe_contents ((self container) limit-type exclude-inherited max-return-objects)
  (when (eql max-return-objects -1)
    (setq max-return-objects most-positive-fixnum))
  (loop for c in (op:contents self limit-type exclude-inherited)
        repeat max-return-objects
        collect (CORBA:Container/Description 
                 :contained_object c
                 :kind (op:def_kind c)
                 :value (describe-contained c))))


;;;  ModuleDef create_module (
;;;                           in RepositoryId id,
;;;                           in Identifier name,
;;;                           in VersionSpec version

(define-method create_module ((self container) id name version)
  (addto self (make-instance 'module-def
                :id id :name name :version version)))


;;;  ConstantDef create_constant (
;;;                               in RepositoryId id,
;;;                               in Identifier name,
;;;                               in VersionSpec version,
;;;                               in IDLType type,
;;;                               in any value                  )

(define-method create_constant ((self container)
                                id name version type value)
  (addto self (make-instance 'constant-def
                :id id :name name :version version
                :type_def type :value value)))

;;;  StructDef create_struct (
;;;                           in RepositoryId id,
;;;                           in Identifier name,
;;;                           in VersionSpec version,
;;;                           in StructMemberSeq members

(define-method create_struct ((self container)
                              id name version members)
  (let ((obj (make-instance 'struct-def
               :id id :name name :version version)))
    (setf (op:members obj) members)
    (addto self obj)))


;;;  /* This operation is missing in the CORBA2 spec! */
;;;  ExceptionDef create_exception (
;;;                                 in RepositoryId id,
;;;                                 in Identifier name,
;;;                                 in VersionSpec version,
;;;                                 in StructMemberSeq members
;;;                                 );

(define-method create_exception ((self container)
                                 id name version members)
  (addto self (make-instance 'exception-def
                :id id
                :name name
                :version version
                :members members)))



;;;  UnionDef create_union (
;;;                         in RepositoryId id,
;;;                         in Identifier name,
;;;                         in VersionSpec version,
;;;                         in IDLType discriminator_type,
;;;                         in UnionMemberSeq members           );

(define-method create_union ((self container)
                             id name version discriminator_type members)
  (check-type discriminator_type CORBA:IDLType)
  (assert (and (typep members 'sequence)
               (every (lambda (x) (typep x 'CORBA:UnionMember))
                      members))
          (members)
          'type-error :datum 'members :expected-type 'corba:unionmemberseq)
  (addto self (make-instance 'union-def
                :id id :name name :version version
                :discriminator_type_def discriminator_type
                :members members)))


;;;  EnumDef create_enum (
;;;                       in RepositoryId id,
;;;                       in Identifier name,
;;;                       in VersionSpec version,
;;;                       in EnumMemberSeq members
;;;                       );

(define-method create_enum ((self container)
                              id name version members)
  (addto self (make-instance 'enum-def
                :id id :name name :version version
                :members members)))


;;;  AliasDef create_alias (
;;;                         in RepositoryId id,
;;;                         in Identifier name,
;;;                         in VersionSpec version,
;;;                         in IDLType original_type    );

(define-method create_alias ((self container)
                             id name version original_type)
  (addto self (make-instance 'alias-def
                :id id :name name :version version
                :original_type_def original_type)))


;;;  InterfaceDef create_interface (
;;;            in RepositoryId id,
;;;            in Identifier name,
;;;            in VersionSpec version,
;;;            in InterfaceDefSeq base_interfaces );

(define-method create_interface ((self container)
                                 id name version base_interfaces)
  (addto self (make-instance 'interface-def
                :id id :name name :version version
                :base_interfaces base_interfaces)))


;;;    ValueBoxDef create_value_box(
;;;                                 in RepositoryId id,
;;;                                 in Identifier name,
;;;                                 in VersionSpec version,
;;;                                 in IDLType original_type_def

(define-method create_value_box ((self container)
                                 id name version original_type_def)
  (addto self (make-instance 'valuebox-def
                :id id :name name :version version
                :original_type_def original_type_def)))

;;;    NativeDef create_native(
;;;                            in RepositoryId id,
;;;                            in Identifier name,
;;;                            in VersionSpec version

(define-method create_native ((self container) id name version )
  (addto self (make-instance 'native-def
                :id id :name name :version version )))

;;;    AbstractInterfaceDef create_abstract_interface(
;;;                                          in RepositoryId id,
;;;                                          in Identifier name,
;;;                                          in VersionSpec version,
;;;                                          in AbstractInterfaceDefSeq base_interfaces

(define-method create_abstract_interface ((self container)
                                 id name version base_interfaces)
  (addto self (make-instance 'abstractinterface-def
                :id id :name name :version version
                :base_interfaces base_interfaces)))
		
;;;    LocalInterfaceDef create_local_interface(
;;;                                             in RepositoryId id,
;;;                                             in Identifier name,
;;;                                             in VersionSpec version,
;;;                                             in InterfaceDefSeq base_interfaces

(define-method create_local_interface ((self container)
                                 id name version base_interfaces)
  (addto self (make-instance 'localinterface-def
                :id id :name name :version version
                :base_interfaces base_interfaces)))


;;; ValueDef create_value

(define-method create_value ((self container)
                              id name version is_custom is_abstract
                              base_value is_truncatable abstract_base_values
                              supported_interfaces initializers)
  (check-type id CORBA:RepositoryId)
  (check-type name CORBA:Identifier)
  (check-type version CORBA:VersionSpec)
  (check-type is_custom CORBA:boolean)
  (check-type is_abstract CORBA:boolean)
  (check-type base_value (or null CORBA:ValueDef))
  (check-type is_truncatable CORBA:boolean)
  (check-type abstract_base_values CORBA:ValueDefSeq)
  (check-type supported_interfaces CORBA:InterfaceDefSeq)
  (check-type initializers CORBA:InitializerSeq)
  (addto self (make-instance 'value-def
                :id id :name name :version version
                :is_custom is_custom  :is_abstract is_abstract
                :base_value base_value :is_truncatable is_truncatable
                :abstract_base_values abstract_base_values
                :supported_interfaces supported_interfaces
                :initializers initializers)))


(define-method op:destroy ((obj container))
  (dolist (x (contents obj))
    (op:destroy x))
  (call-next-method))

		


;;;; interface Repository : Container

(define-ir-class Repository (CORBA:Repository Container)
  :def_kind :dk_repository
  :slots ((idmap :initform (make-hash-table :test #'equal)
                 :reader idmap)
          (primitives-cache
           :initform nil
           :accessor primitives-cache )))


;;; Method to simplify computation of absolute_name
(define-method absolute_name ((obj Repository))
  "")

(define-method containing_repository ((r Repository))
  r)

(defmethod subject-id ((r repository))
  "")

;;;  Contained lookup_id (in RepositoryId search_id);

(define-method lookup_id ((rep repository) id)
  (gethash id (idmap rep)))


;;; TypeCode get_canonical_typecode(in TypeCode tc);

(define-method get_canonical_typecode ((container Repository) tc)
  (flet ((reconstruct ()
           (map-typecode (lambda (tc) (op:get_canonical_typecode container tc))
                         tc)))
    (handler-case
      (let ((id (op:id tc)))
        (let ((obj (op:lookup_id container id)))
          (if obj
            (op:type obj)
            (reconstruct))))
      (CORBA:TYPECODE/BADKIND () (reconstruct)))))



;;;  PrimitiveDef get_primitive (in PrimitiveKind kind);

(define-method get_primitive ((container Repository) kind)
  (with-accessors ((cache primitives-cache)) container
    (unless cache
      (setf cache
            (loop for (kind tc) 
                  in '((:pk_null CORBA:tc_null)
                       (:pk_void CORBA:tc_void)
                       (:pk_short CORBA:tc_short)
                       (:pk_long CORBA:tc_long)
                       (:pk_ushort CORBA:tc_ushort)
                       (:pk_ulong CORBA:tc_ulong)
                       (:pk_float CORBA:tc_float)
                       (:pk_double CORBA:tc_double)
                       (:pk_boolean CORBA:tc_boolean)
                       (:pk_char CORBA:tc_char)
                       (:pk_octet CORBA:tc_octet)
                       (:pk_any CORBA:tc_any)
                       (:pk_typecode CORBA:tc_TypeCode)
                       ;;(:pk_Principal CORBA:tc_Principal)
                       (:pk_string CORBA:tc_string)
                       (:pk_objref CORBA:tc_object)
                       (:pk_longlong CORBA:tc_longlong)
                       (:pk_ulonglong CORBA:tc_ulonglong)
                       (:pk_longdouble CORBA:tc_longdouble)
                       (:pk_wchar CORBA:tc_wchar)
                       (:pk_wstring CORBA:tc_wstring)
                       (:pk_value_base corba:tc_valuebase))
                  collect (make-instance 'primitive-def :kind kind 
                                         :type (symbol-value tc)))))
    (find kind cache :key #'op:kind)))


;;;  StringDef create_string (in unsigned long bound);

(define-method create_string ((container Repository) bound)
  (make-instance 'string-def
    :bound bound))

;;;  WstringDef create_wstring (in unsigned long bound);

(define-method create_wstring ((container Repository) bound)
  (make-instance 'wstring-def
    :bound bound))


;;;  SequenceDef create_sequence
;;;     (in unsigned long bound,in IDLType element_type);

(define-method create_sequence ((container Repository) bound element-type)
  (check-type bound integer)
  (check-type element-type corba:idltype)
  (make-instance 'sequence-def
    :bound bound
    :element_type_def element-type))


;;;  ArrayDef create_array
;;;     (in unsigned long length,in IDLType element_type);

(define-method create_array ((container Repository) length element_type)
  (make-instance 'array-def
    :length length
    :element_type_def element_type))


;;;  FixedDef create_fixed
;;;     (in unsigned short digits,in short scale);

(define-method create_fixed ((container Repository) digits scale)
  (make-instance 'fixed-def
    :digits digits
    :scale scale))


(define-method op:destroy ((obj repository))
  (raise-system-exception 'omg.org/corba:bad_inv_order
                          2 :completed_yes))




;;;; ModuleDef

(define-ir-class module-def (CORBA:ModuleDef container contained)
  :def_kind :dk_module)


(defmethod describe-contained ((module module-def))
  (CORBA:ModuleDescription
   :name (op:name module)
   :id (op:id module)
   :defined_in (or (op:defined_in module) "")
   :version (op:version module)))


;;;; interface ConstantDef : Contained {
;;;   readonly attribute TypeCode type;
;;;   attribute IDLType type_def;
;;;   attribute any value; };

(define-ir-class constant-def (CORBA:ConstantDef contained)
  :def_kind :dk_constant
  :attributes ((type_def)
               (value)))


(define-method type ((obj constant-def))
  (op:type (op:type_def obj)))



;;;; InterfaceDef

(define-ir-class interface-def (CORBA:InterfaceDef container contained idltype)
  :def_kind :dk_interface 
  :attributes ((base_interfaces)))

(defmethod idltype-tc ((idef interface-def))
  (create-interface-tc (subject-id idef) (op:name idef)))

(define-method is_a ((def interface-def) interface-id)
  (or
   (equal (subject-id def) interface-id)
   (equal interface-id (symbol-ifr-id 'corba:object))
   (some (lambda (b) (equal interface-id (op:id b)))
         (op:base_interfaces def))))

(define-method describe_interface ((def interface-def))
  (CORBA:InterfaceDef/FullInterfaceDescription
   :name (op:name def)
   :id   (subject-id def)
   :defined_in (subject-id (op:defined_in def))
   :version (op:version def)
   :operations (map 'list #'operation-description
                    (op:contents def :dk_operation nil))
   :attributes (map 'list #'describe-contained
                    (op:contents def :dk_attribute nil))
   :base_interfaces (map 'list #'subject-id (op:base_interfaces def))
   :type (op:type def) ))

(defmethod describe-contained ((def interface-def))
  (CORBA:InterfaceDescription
   :name (op:name def)
   :id   (subject-id def)
   :defined_in (subject-id (op:defined_in def))
   :version (op:version def)
   :base_interfaces (map 'list #'subject-id (op:base_interfaces def))))

(define-method contents ((obj interface-def) limit-type exclude-inherit)
  (if exclude-inherit
      (call-next-method)
    (append (call-next-method)
            (loop for x in (coerce (op:base_interfaces obj) 'list)
                append (op:contents x limit-type nil)))))


(defun check-unique-name (container name &key (minor 3))
  (when (op:lookup_name container name 1 :dk_all nil)
    (raise-system-exception 'CORBA:bad_param minor)))

(define-method (setf op:base_interfaces) :before (value (self interface-def))
  (loop for obj in (contents self) do
        (loop for base in value do
              (check-unique-name base (op:name obj) :minor 5))))


;;;  AttributeDef create_attribute

(define-method create_attribute ((self interface-def)
                                 id name version type mode)
  (check-type id string)                ; RepositoryId
  (check-type name string)              ; Identifier
  (check-type version string)           ; VersionSpec
  (check-type type IDLType)
  (check-type mode CORBA:AttributeMode)
  (check-unique-name self name)
  (addto self (make-instance 'attribute-def
                :id id :name name :version version
                :type_def type :mode mode)))


;;;  OperationDef create_operation

(define-method create_operation ((self interface-def)
                                 id name version
                                 result mode params exceptions contexts)
  (check-type id string)                ; RepositoryId
  (check-type name string)              ; Identifier
  (check-type version string)           ; VersionSpec
  (check-type result IDLType)
  (check-type mode CORBA:OperationMode)
  (check-type params CORBA:ParDescriptionSeq)
  (check-type exceptions CORBA:ExceptionDefSeq)
  (check-type contexts CORBA:ContextIdSeq)
  (check-unique-name self name)
  (addto self (make-instance 'operation-def
                :id id :name name :version version
                :result_def result :mode mode
                :params params :exceptions exceptions
                :contexts contexts)))



;;;; AttributeDef

(define-ir-class attribute-def (CORBA:AttributeDef contained)
  :def_kind :dk_attribute
  :attributes ((type_def)
               (mode)))


(define-method type ((adef attribute-def))
  (op:type (op:type_def adef)))

(defmethod describe-contained ((adef attribute-def))
  (CORBA:AttributeDescription
   ;; Identifier name
   :name (op:name adef)
   ;; RepositoryId id
   :id (op:id adef)
   ;; RepositoryId defined_in
   :defined_in (subject-id (op:defined_in adef))
   ;; VersionSpec version
   :version (op:version adef)
   ;; TypeCode type
   :type (op:type adef)
   ;; AttributeMode mode
   :mode (op:mode adef)))



;;;; OperationDef

(define-ir-class operation-def (CORBA:OperationDef contained)
  :def_kind :dk_operation
  :attributes ((result :readonly :virtual result)
               (result_def)
               (params nil)
               (mode ':op_normal)
               (contexts nil)
               (exceptions nil)))


(defun validate-operation-def (mode result params exceptions)
  (when (eq mode :op_oneway)
    (unless (and (eq :tk_void (op:kind (op:type result)))
                 (zerop (length exceptions))
                 (every (lambda (p)
                          (eq :param_in (op:mode p)))
                        params))
      (raise-system-exception 'CORBA:bad_param 31 :completed_yes))))

(defun validate-operation-def-change (def &key 
                                            (mode (op:mode def))
                                            (result (op:result_def def))
                                            (params (slot-value def 'params))
                                            (exceptions (op:exceptions def)))
  (validate-operation-def mode result params exceptions))

(defmethod initialize-instance :before ((def operation-def)
                                        &key result_def mode params exceptions)
  (validate-operation-def mode result_def params exceptions))

(defmethod (setf op:result_def) :before (new (def operation-def)) 
  (validate-operation-def-change def :result new))

(defmethod (setf op:mode) :before (new (def operation-def))
  (validate-operation-def-change def :mode new))               

(defmethod (setf op:params) :before (new (def operation-def))
  (validate-operation-def-change def :params new))               

(defmethod (setf op:exceptions) :before (new (def operation-def))
  (validate-operation-def-change def :exceptions new))               

(defmethod result ((opdef operation-def))
  (op:type (slot-value opdef 'result_def)))

(defmethod op:params :before ((opdef operation-def) &key)
  (doseq (pd (slot-value opdef 'params))
         (setf (op:type pd) (op:type (op:type_def pd)))))


(defmethod opdef-inparam-typecodes ((opdef operation-def))
  (loop for param in (op:params opdef)
      unless (eq (op:mode param) :param_out)
      collect (op:type param)))

#+unused-defuns
(defmethod opdef-outparam-typecodes ((opdef operation-def))
  (let ((real-params
         (loop for param in (op:params opdef)
             unless (eq (op:mode param) :param_in)
             collect (op:type param)))
        (result (op:result opdef)))
    (if (eq :tk_void (typecode-kind result))
        real-params
      (cons result real-params))))




(defun operation-description (opdef)
  ;;  struct OperationDescription
  (CORBA:OperationDescription
   ;;  Identifier name;
   :name (op:name opdef)
   ;;  RepositoryId id;
   :id   (op:id opdef)
   ;;  RepositoryId defined_in;
   :defined_in (op:id (op:defined_in opdef))
   ;;  VersionSpec version;
   :version (op:version opdef)
   ;;  TypeCode result;
   :result (op:result opdef)
   ;;  OperationMode mode;
   :mode (op:mode opdef)
   ;;  ContextIdSeq contexts;
   :contexts (op:contexts opdef)
   ;;  ParDescriptionSeq parameters;
   :parameters (op:params opdef)
   ;;  ExcDescriptionSeq exceptions;
   :exceptions (map 'list
                    'describe-contained (op:exceptions opdef))))

(defmethod describe-contained ((obj operation-def))
  (operation-description obj))


;;;; TypedefDef

(define-ir-class typedef-def (CORBA:TypedefDef contained idltype)
  :def_kind :dk_typedef)


(defmethod describe-contained ((obj typedef-def))
  (CORBA:TypeDescription
   ;; Identifier name
   :name (op:name obj)
   ;; RepositoryId id
   :id (op:id obj)
   ;; RepositoryId defined_in
   :defined_in (subject-id (op:defined_in obj))
   ;; VersionSpec version
   :version (op:version obj)
   ;; TypeCode type
   :type (op:type obj)))


;;;; interface AliasDef : TypedefDef
;;  attribute IDLType original_type_def;

(define-ir-class alias-def (corba:AliasDef typedef-def)
  :def_kind :dk_alias
  :attributes ((original_type_def)))


(defmethod idltype-tc ((def alias-def))
  (create-alias-tc (op:id def) (op:name def)
                   (op:type (op:original_type_def def))))

(define-method op:destroy ((obj alias-def))
  (let ((orig (op:original_type_def obj)))
    (when (and (typep orig 'CORBA:IDLtype)
               (typep orig 'CORBA:Contained))
      (op:destroy orig)))
  (call-next-method))





;;;; interface StructDef : TypedefDef
;; attribute StructMemberSeq members;
;; struct StructMember {
;;  Identifier name;
;;  TypeCode type;
;;  IDLType type_def;

(define-ir-class struct-def (corba:StructDef typedef-def container)
  :def_kind :dk_struct
  :attributes ((members)))


(defmethod moveto :before ((c struct-def) (object contained) new-name new-version)
  (declare (ignore new-name new-version))
  (typecase object 
    ((or Struct-Def Union-Def Enum-Def))
    (otherwise
     (raise-system-exception 'CORBA:BAD_PARAM 4))))


(defmethod op:members :before ((obj struct-def) &rest x)
  (declare (ignore x))
  (doseq (m (slot-value obj 'members))
    (setf (op:type m) (op:type (op:type_def m)))))


(defmethod idltype-tc ((def struct-def))
  (create-struct-tc (op:id def) (op:name def) (simple-struct-members (op:members def))))



;;;; interface UnionDef : TypedefDef
;;;   readonly attribute TypeCode discriminator_type;
;;;   attribute IDLType discriminator_type_def;
;;;   attribute UnionMemberSeq members;

;;; struct UnionMember {
;;;   Identifier name;
;;;   any label;
;;;   TypeCode type;
;;;   IDLType type_def;
;;; typedef sequence <UnionMember> UnionMemberSeq;

(define-ir-class union-def (CORBA:UnionDef typedef-def container)
  :def_kind :dk_union
  :attributes ((discriminator_type_def)
               (members)))

(defmethod moveto :before ((c union-def) (object contained) new-name new-version)
  (declare (ignore new-name new-version))
  (typecase object 
    ((or Struct-Def Union-Def Enum-Def))
    (otherwise
     (raise-system-exception 'CORBA:BAD_PARAM 4))))

(define-method discriminator_type ((obj union-def))
  (op:type (op:discriminator_type_def obj)))

(defmethod op:members :before ((self union-def) &rest args)
  (declare (ignore args))
  (doseq (member (slot-value self 'members))
    (setf (op:type member) (op:type (op:type_def member)))))

(defmethod idltype-tc ((obj union-def))
  ;; FIXME: should be simpler to use op:create_union_tc
  (flet ((default-label-p (label)
           (and (not (symbolp label))
                (eql :tk_octet (op:kind (any-typecode label)))
                (= 0 (any-value label)))))
    (create-union-tc (op:id obj) (op:name obj)
                     (op:discriminator_type obj)
                     (map 'list (lambda (m)
                                  (list (if (default-label-p (op:label m))
                                          'default
                                          (op:label m))
                                        (op:name m)
                                        (op:type m)))
                          (op:members obj)))))



;;;; EnumDef

(define-ir-class enum-def (corba:EnumDef typedef-def)
  :def_kind :dk_enum
  :attributes ((members)))


(defmethod idltype-tc ((obj enum-def))
  (create-enum-tc (op:id obj) (op:name obj) (op:members obj)))


;;;; interface ExceptionDef : Contained, Container
;;;  readonly attribute TypeCode type;
;;;  attribute StructMemberSeq members;

(define-ir-class exception-def (corba:ExceptionDef contained container
                                                   irtypecode-mixin)
  :def_kind :dk_exception
  :attributes ((members)))


(defmethod moveto :before ((c exception-def) (object contained) new-name new-version)
  (declare (ignore new-name new-version))
  (typecase object 
    ((or Struct-Def Union-Def Enum-Def))
    (otherwise
     (raise-system-exception 'CORBA:BAD_PARAM 4))))


(defmethod op:members :before ((obj exception-def) &rest x)
  (declare (ignore x))
  (doseq (m (slot-value obj 'members))
    (setf (op:type m) (op:type (op:type_def m)))))


(defmethod idltype-tc ((obj exception-def))
  (create-exception-tc (op:id obj) (op:name obj)
                       (simple-struct-members (op:members obj))))


(defmethod describe-contained ((obj exception-def))
  (CORBA:ExceptionDescription
   ;;  Identifier name;
   :name (op:name obj)
   ;;  RepositoryId id;
   :id (op:id obj)
   ;;  RepositoryId defined_in;
   :defined_in (subject-id (op:defined_in obj))
   ;;  VersionSpec version;
   :version (op:version obj)
   ;;  TypeCode type;
   :type (op:type obj)))



;;;; PrimitiveDef

(define-ir-class primitive-def (corba:PrimitiveDef idltype)
  :def_kind :dk_primitive
  :attributes ((kind))
  :slots ((type :initarg :type)) ; add initarg
)


(defmethod print-object ((obj primitive-def) stream)
  (print-unreadable-object (obj stream :type t :identity t)
    (format stream "~A" (slot-value obj 'kind))))

(define-method op:destroy ((obj primitive-def))
  (raise-system-exception 'omg.org/corba:bad_inv_order
                          2 :completed_yes))



;;;; interface StringDef : IDLType
;;;  attribute unsigned long bound;

(define-ir-class string-def (corba:StringDef idltype)
  :def_kind :dk_string
  :attributes ((bound 0)))

(defmethod idltype-tc ((obj string-def))
  (create-string-tc (op:bound obj)))



;;;; interface WstringDef : IDLType
;;;  attribute unsigned long bound;

(define-ir-class wstring-def (corba:WstringDef idltype)
  :def_kind :dk_wstring
  :attributes ((bound 0)))


(defmethod idltype-tc ((obj wstring-def))
  (create-wstring-tc (op:bound obj)))


;;;; SequenceDef
;;interface SequenceDef : IDLType
;;  attribute unsigned long bound;
;;  readonly attribute TypeCode element_type;
;;  attribute IDLType element_type_def;

(define-ir-class sequence-def (corba:SequenceDef IDLType)
  :def_kind :dk_sequence
  :attributes ((bound 0)                  ; long
               ;;(element_type :readonly) ; TypeCode
               (element_type_def))      ; IDLType
  :defaults ())

(define-method element_type ((obj sequence-def))
  (op:type (op:element_type_def obj)))

(defmethod idltype-tc ((obj sequence-def))
  (create-sequence-tc (op:bound obj) (op:element_type obj)))



;;;; ArrayDef : IDLType
;;        attribute unsigned long         length;
;;        readonly attribute TypeCode     element_type;
;;        attribute IDLType               element_type_def;

(define-ir-class array-def (CORBA:ArrayDef idltype)
  :def_kind :dk_array
  :attributes ((length 0)
               (element_type_def)))

(define-method element_type ((obj array-def))
  (op:type (op:element_type_def obj)))

{'fraction_non_alphanumeric': 0.11370430446264596, 'fraction_numerical': 0.001501400860624422, 'mean_word_length': 2.3605730245968104, 'pattern_counts': {'":': 4, '<': 5, '<?xml version=': 0, '>': 7, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 140, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '6292390', 'n_tokens_mistral': 22495, 'n_tokens_neox': 21421, 'n_words': 5959}