      *>----------------------------------------------------------------
      *> DOCS-ROOT.
      *> Intrinsic is an abstract class which represents the common
      *> behavior for all COBOL intrinsic data types.
      *>
      *> Copyright (C) 1991-1999 Micro Focus International Ltd.
      *>
      *>----------------------------------------------------------------
      $set mfoo
       class-id. intrinsic is abstract data is protected
               inherits from base with data.


        object section.
        class-control.
           Base is class "base"
           intrinsic is class "intrnsic"
           cobolcomp5 is class "comp5"
           cobolcompx is class "compx"
           orderedcollection is class "ordrdcll"
           cobolpicx is class "picx"
           cobolComp5Association is class "compasoc"
           association is class "associtn"
           .
       special-names.
           call-convention 4 is logical
           .

       class-object.

       object-storage section.

      *>>---------------------------------------------------------------
      *>> represents the number of bytes required to store an instance
      *>> of this intrinsic class
      *>>---------------------------------------------------------------

       01 storagerequirements  pic x(4) comp-5 value 0.

      *>----------------------------------------------------------------
      *> Return a template which can be used when creating collections.
      *> Length of template must be specified. Hence only data of the
      *> same length can be stored in collections.
      *> If you need to store variable length Intrinsics in
      *> collections, then you need to create instances of the intrinsic
      *> subclasses and store those.
      *>----------------------------------------------------------------
       method-id. "newClass".
       local-storage section.
       01 exceptionnumber             pic s9(9) comp-5.
       01 aSize                       pic s9(9) comp-5.

       linkage section.
       01 alength        pic s9(9) comp-5.
       01 lnkclass              usage object reference.

       procedure division using alength returning lnkclass.
          invoke self "maximumSize" returning asize
          if alength > asize
             move 30 to exceptionnumber
             invoke self "raiseException" using exceptionnumber
                                           returning lnkclass
          else
             invoke self "basicCopy" returning lnkclass
             invoke lnkclass "SetLength" using alength
          end-if
       exit method.
       end method "newClass".
      *>----------------------------------------------------------------
      *> PRIVATE. Set the length of this intrinsic to aLength
      *>----------------------------------------------------------------
       method-id. "SetLength".
       linkage section.
       01 alength        pic s9(9) comp-5.

       procedure division using alength.
           move alength to storagerequirements
           exit method.
       end method "SetLength".

      *>----------------------------------------------------------------
      *> Return a boolean indicating whether this static structure
      *> contains objects or not.
      *>----------------------------------------------------------------
       method-id. "storingObjects".
       linkage section.
       01 lnkBool                pic x comp-5.
        88 storingObjects       value 1.
        88 notstoringObjects       value 0.
       procedure division returning lnkBool.
           set notStoringobjects to true
           exit method.
       end method "storingObjects".

      *>----------------------------------------------------------------
      *> Return the length of this intrinsic
      *>----------------------------------------------------------------
       method-id. "size".
       linkage section.
       01 alength        pic s9(9) comp-5.

       procedure division returning alength.
           move storagerequirements to alength
           exit method.
       end method "size".


      *>----------------------------------------------------------------
      *> Return the length in bytes of this intrinsic
      *>----------------------------------------------------------------
       method-id. "sizeInBytes".
       linkage section.
       01 alength        pic s9(9) comp-5.

       procedure division returning alength.
           move storagerequirements to alength
           exit method.
       end method "sizeInBytes".
      *>----------------------------------------------------------------
      *> Return an instance of an Intrinsic with an undefined value
      *>----------------------------------------------------------------
       method-id. "new".
       local-storage section.
       01 exceptionnumber            pic s9(9) comp-5.

       linkage section.
       01 anintrinsic          usage object reference.

       procedure division returning anintrinsic.
           invoke self "newindexedinstance" using storagerequirements
                                     returning anintrinsic
           if anintrinsic equal to null
              move 23 to exceptionnumber
              invoke self "raiseException" using exceptionnumber
                                         returning anintrinsic
           end-if
           exit method.
       end method "new".
      *>----------------------------------------------------------------
      *> Return an instance of an Intrinsic with a value of aValue
      *>----------------------------------------------------------------
       method-id. "withValue".
       linkage section.
       01 anintrinsic          usage object reference.
       01 avalue.
           03 abyte      pic x  occurs 0 to maxnumberbytes
                               depending on storagerequirements.

       procedure division using avalue returning anintrinsic.
          if self equal intrinsic
               invoke self "implementedBySubClass"
                                           returning anintrinsic
          else
              invoke self "new" returning anintrinsic
              if anintrinsic not equal to null
                    invoke anintrinsic "setValue" using avalue
              end-if
          end-if
          exit method.
       end method "withValue".
      *>----------------------------------------------------------------
      *> Return the maximum possible size of instances.
      *>----------------------------------------------------------------
       method-id. "maximumSize".
       linkage section.
       01 alength        pic s9(9) comp-5.

       procedure division returning alength.
           move maxnumberbytes to alength.
           exit method.
       end method "maximumSize".

      *>----------------------------------------------------------------
      *> PRIVATE. Given an abstract machine descriptor, return
      *> object reference of corresponding class.
      *>----------------------------------------------------------------
       method-id. "getclassfromdatadescription".
       local-storage section.
       01  data-descriptor.
           03  dd1 pic x comp-x.
           03  dd2 pic x comp-x.
       01  .
           03  data-length pic xxxx comp-5.
           03  data-alignment pic xxxx comp-5.
           03  mask1  pic x comp-x.
           03  mask1b pic x comp-x.
           03  mask2  pic xx comp-x.
       linkage section.
       01 lnk-data-descriptor pic xx.
       01 lnk-data-type pic x comp-x.
       01 lnk-objref         object reference.

       procedure division using lnk-data-type lnk-data-descriptor
                          returning lnk-objref.
           set lnk-objref to null
           move h'80' to mask1
           call logical "CBL_AND" using lnk-data-descriptor mask1
                                            by value 1 size 4
           if lnk-data-type = 0 then
               *> alphanumeric descriptor - calculate length
               if mask1 = 0
                   *> one byte descriptor
                   move h'1f' to mask1
                   call logical "CBL_AND" using lnk-data-descriptor
                                                mask1
                                                by value 1 size 4
                   move mask1 to data-length
                   add 1 to data-length
                   invoke cobolpicx "newclass" using data-length
                                               returning lnk-objref
                   exit method
               else
                   *> two byte descriptor
                   move h'1fff' to mask2
                   call logical "CBL_AND" using lnk-data-descriptor
                                                mask2
                                                by value 2 size 4
                   move mask2 to data-length
                   add 1 to data-length
                   invoke cobolpicx "newclass" using data-length
                                                returning lnk-objref
                   exit method
               end-if
           end-if
           *> numeric descriptor
           if mask1 = 0
               *> one byte descriptor
               move lnk-data-descriptor(1:1) to dd1
               move h'91' to dd2
           else
               *> two byte descriptor
               move lnk-data-descriptor(1:2) to data-descriptor(1:2)
           end-if
           move h'1f' to mask1
           call logical "CBL_AND" using dd1 mask1
                                    by value 1 size 4
           move mask1 to data-length
           if mask1 < 19 then
               add 1 to data-length
               move h'1f' to mask1
               call logical "CBL_AND" using dd2 mask1
                                    by value 1 size 4
               move mask1 to data-alignment
               add 1 to data-alignment
           else
               move h'1c' to mask1
               call logical "CBL_AND" using dd2 mask1
                                    by value 1 size 4
               add mask1 to data-length
               subtract 19 from data-length
               move 3 to mask1
               call logical "CBL_AND" using dd2 mask1
                                    by value 1 size 4
               move mask1 to data-alignment
               add 32 to data-alignment
           end-if
           move h'40' to mask1
           call logical "CBL_AND" using dd1 mask1
                                    by value 1 size 4
           move h'60' to mask1b
           call logical "CBL_AND" using dd2 mask1b
                                    by value 1 size 4
           if mask1 = 0
               *> usage display or comp-6
               move h'80' to mask1
               call logical "CBL_AND" using dd2 mask1
                                    by value 1 size 4
               if mask1 not = 0 and mask1b = 1 then
                   *> comp-6
                   invoke self "getclassfromname" using "cobolcomp6"
                                   "comp6"
                                   data-length
                                   returning lnk-objref
                   exit method
               else
                   *> usage display (signed or unsigned)
                   invoke self "getclassfromname" using "pic9display"
                                   "pic9disp"
                                   data-length
                                   returning lnk-objref
                   exit method
               end-if
           else
               if mask1b = 0 or 40 then
                   *> comp or comp-x
                   invoke cobolcompx "newclass" using data-length
                                               returning lnk-objref
                   exit method
               else
                   if mask1b = 60 then
                       *> comp-5
                       invoke cobolcomp5 "newclass" using data-length
                                               returning lnk-objref
                       exit method
                   else
                       invoke self "getclassfromname" using
                                   "cobolcomp3" "comp3" data-length
                                   returning lnk-objref
                       exit method
                   end-if
               end-if
           end-if
           exit method.
       end method "getclassfromdatadescription".

      *>----------------------------------------------------------------
      *> PRIVATE. Given a class name and length, return
      *> object reference of corresponding class.
      *>----------------------------------------------------------------

       method-id. "getclassfromname".
       local-storage section.
       01 classobj object reference.
       01  pp1x.
           03  pp1 procedure-pointer.
       01  pp2x.
           03  pp2 procedure-pointer.
       01  doesnotexist pic xx.
       linkage section.
       01 lnk-class-name pic x.
       01 lnk-filename pic x.
       01 lnk-data-length pic x comp-x.
       01 lnk-objref         object reference.

       procedure division using lnk-class-name
                                lnk-filename
                                lnk-data-length
                        returning lnk-objref.
           move spaces to doesnotexist
           set pp1 to entry doesnotexist
           set pp2 to entry lnk-filename
           if pp1x = pp2x then
               *> raise exception
               exit method
           end-if
           call "oopsgetclassobject" using lnk-filename
                          returning classobj
           invoke classobj "newclass" using lnk-data-length
                          returning lnk-objref.
           exit method.
       end method "getclassfromname".

       end class-object.

       Object.

       object-storage section.
       01 instancedata.
           05 filler pic x.
      *>--------------------------------------------------------------
      *> PRIVATE. Return a pointer to a newly allocated piece of memory
      *> is lnkSize bytes large.
      *>--------------------------------------------------------------
       method-id. "AllocateElements".
       local-storage section.
       01 i            pic x(4) comp-5.
       01 collectionStride pic x(4) comp-5.
       linkage section.
       01 lnkSize           pic x(4) comp-5.
       01 lnkPtr            usage pointer.

       procedure division using lnkSize returning lnkPtr.
           move lnkSize to i
           invoke self "sizeInBytes" returning collectionStride
           multiply collectionStride by i
           call "oopsallocmemory" using by value i
                                returning lnkPtr
           exit method
       end method "AllocateElements".
      *>--------------------------------------------------------------
      *> PRIVATE. Return a pointer to a newly allocated piece of memory
      *> which is lnkSize bytes large.
      *>--------------------------------------------------------------
       method-id. "AllocateElement".
       local-storage section.
       01 collectionStride  pic x(4) comp-5.
       linkage section.
       01 lnkPtr            usage pointer.

       procedure division returning lnkPtr.
           invoke self "sizeInBytes" returning collectionStride
           call "oopsallocmemory" using by value collectionStride
                                returning lnkPtr
       end method "AllocateElement".
      *>----------------------------------------------------------------
      *> Return the length of this Intrinsic
      *>----------------------------------------------------------------
       method-id. "size".
       linkage section.
       01 alength        pic s9(9) comp-5.

       procedure division returning alength.
           invoke selfclass "size" returning aLength
           exit method.
       end method "size".

      *>----------------------------------------------------------------
      *> Set the Value of this Intrinsic
      *> Note that the number of bytes read from avalue is equal to
      *> the current size of the Intrinsic.
      *>----------------------------------------------------------------
       method-id. "setValue".
       local-storage section.
       01 i             pic x(4) comp-5.
       linkage section.
       01 avalue        pic x.
       procedure division using avalue.
           invoke self "sizeInBytes" returning i
           move avalue(1:i) to instancedata(1 : i)
           exit method.
       end method "setValue".
      *>----------------------------------------------------------------
      *> Return the value of this Intrinsic
      *>----------------------------------------------------------------
       method-id. "getValue".
       local-storage section.
       01 i             pic x(4) comp-5.

       linkage section.
       01 avalue        pic x(4) comp-5.

       procedure division returning avalue.
           invoke self "sizeInBytes" returning i
           move instancedata(1: i) to avalue(1:i)
           exit method.
       end method "getValue".

      *>----------------------------------------------------------------
      *> Return True if this intrinsic is less than the instance
      *> anobject else return False.
      *>----------------------------------------------------------------
       method-id. "LessThan".
       local-storage section.

       01 comparelength   pic x(4) comp-5.
       01 aptr            usage pointer.
       01 numChars        pic x(4) comp-5.

       linkage section.
       01 comparevalue.
           03 abyte      pic x occurs 1 to maxnumberbytes depending on
                                   comparelength.
       01 lnkbool           pic x comp-5.
           88  lnkistrue  value 1.
           88  lnkisfalse value 0.

       01 anobject         usage object reference.

       procedure division using anobject returning lnkbool.
           invoke anObject "sizeInBytes" returning compareLength
           invoke anObject "size" returning numChars
           invoke self "malloc" using compareLength returning aptr
           set address of compareValue to aptr
           invoke anObject "getValue" returning compareValue
           invoke self "LessThanbyLengthValue" using numChars
                                                        compareValue
                                              returning lnkBool
           invoke self "dealloc" using aptr
           exit method.
       end method "LessThan".
      *>----------------------------------------------------------------
      *> Return True if this object is greater than the instance
      *> anobject else return False.
      *>----------------------------------------------------------------
       method-id. "greaterThan".
       local-storage section.

       01 comparelength   pic x(4) comp-5.
       01 aptr            usage pointer.
       01 numChars        pic x(4) comp-5.

       linkage section.
       01 comparevalue.
           03 abyte      pic x occurs 1 to maxnumberbytes depending on
                                   comparelength.
       01 lnkbool          pic x comp-5.
           88  lnkistrue  value 1.
           88  lnkisfalse value 0.

       01 anobject         usage object reference.

       procedure division using anobject returning lnkbool.
           invoke anObject "sizeInBytes" returning compareLength
           invoke anObject "size" returning numChars
           invoke self "malloc" using compareLength returning aptr
           set address of compareValue to aptr
           invoke anObject "getValue" returning compareValue
           invoke self "greaterThanbyLengthValue" using numChars
                                                        compareValue
                                              returning lnkBool
           invoke self "dealloc" using aptr
           exit method.
       end method "greaterThan".
      *>----------------------------------------------------------------
      *> Return True if the instance anIntrinsic is equal to this
      *> CobolPICX else return False.
      *>----------------------------------------------------------------
       method-id. "equal".
       local-storage section.

       01 comparelength   pic x(4) comp-5.
       01 aptr            usage pointer.
       01 sReq            pic x(4) comp-5.
       01 numChars        pic x(4) comp-5.

       linkage section.
       01 comparevalue.
           03 abyte      pic x occurs 1 to maxnumberbytes depending on
                                   comparelength.
       01 anintrinsic      usage object reference.
       01 lnkbool          pic x comp-5.
           88  lnkistrue  value 1.
           88  lnkisfalse value 0.

       procedure division using anintrinsic returning lnkbool.
           invoke anintrinsic "sizeInBytes" returning compareLength
           invoke self "malloc" using compareLength returning aptr
           set address of comparevalue to aptr
           invoke anintrinsic "getValue" returning compareValue
           invoke anIntrinsic "size" returning numChars
           invoke self "equalbylengthValue" using numChars compareValue
                           returning lnkBool
           invoke self "dealloc" using aptr
           exit method.
       end method "equal".
      *>----------------------------------------------------------------
      *> Return an error as this should be implemented by a subclass of
      *> intrinsic.
      *>----------------------------------------------------------------
       method-id. "lessThanbyLengthValue".
       linkage section.
       01 voidparam2           usage object reference.
       01 bool                 pic x comp-5.
           88 istrue   value 1.
           88 isfalse  value 0.
       01 voidparam            usage object reference.

       procedure division using voidparam voidparam2
                      returning bool.
           invoke self "implementedBySubclass" returning bool
           exit method.
       end method "lessThanbyLengthValue".
      *>----------------------------------------------------------------
      *> Return an error as this should be implemented by a subclass of
      *> intrinsic
      *>----------------------------------------------------------------
       method-id. "greaterThanbyLengthValue".
       linkage section.
       01 voidparam2           usage object reference.
       01 bool                 pic x comp-5.
           88 istrue   value 1.
           88 isfalse  value 0.
       01 voidparam            usage object reference.

       procedure division using voidparam voidparam2
                      returning bool.
           invoke self "implementedBySubclass" returning bool
           exit method.
       end method "greaterThanbyLengthValue".
      *>----------------------------------------------------------------
      *> Return an error as this should be implemented by a subclass of
      *> intrinsic
      *>----------------------------------------------------------------
       method-id. "equalbyLengthValue".
       linkage section.
       01 voidparam2           usage object reference.
       01 bool                 pic x comp-5.
           88 istrue   value 1.
           88 isfalse  value 0.
       01 voidparam            usage object reference.

       procedure division using voidparam voidparam2
                      returning bool.
           invoke self "implementedBySubclass" returning bool
           exit method.
       end method "equalbyLengthValue".
      *>----------------------------------------------------------------
      *> Return True if this intrinsic is less than or equal the
      *> instance anobject else return False.
      *>----------------------------------------------------------------
       method-id. "LessThanOrEqual".
       local-storage section.

       01 comparelength   pic x(4) comp-5.
       01 aptr            usage pointer.
       01 numChars        pic x(4) comp-5.

       linkage section.
       01 comparevalue.
           03 abyte      pic x occurs 1 to maxnumberbytes depending on
                                   comparelength.
       01 lnkbool           pic x comp-5.
           88  lnkistrue  value 1.
           88  lnkisfalse value 0.

       01 anobject         usage object reference.

       procedure division using anobject returning lnkbool.
           invoke anObject "sizeInBytes" returning compareLength
           invoke anObject "size" returning numChars
           invoke self "malloc" using compareLength returning aptr
           set address of compareValue to aptr
           invoke anObject "getValue" returning compareValue
           invoke self "LessThanOrEqualbyLengthValue" using numChars
                                                        compareValue
                                              returning lnkBool
           invoke self "dealloc" using aptr
           exit method.
       end method "LessThanOrEqual".
      *>----------------------------------------------------------------
      *> Return True if this object is greater than the instance
      *> anobject else return False.
      *>----------------------------------------------------------------
       method-id. "greaterThanOrEqual".
       local-storage section.

       01 comparelength   pic x(4) comp-5.
       01 aptr            usage pointer.
       01 numChars        pic x(4) comp-5.

       linkage section.
       01 comparevalue.
           03 abyte      pic x occurs 1 to maxnumberbytes depending on
                                   comparelength.
       01 lnkbool           pic x comp-5.
           88  lnkistrue  value 1.
           88  lnkisfalse value 0.

       01 anobject         usage object reference.

       procedure division using anobject returning lnkbool.
           invoke anObject "sizeInBytes" returning compareLength
           invoke anObject "size" returning numChars
           invoke self "malloc" using compareLength returning aptr
           set address of compareValue to aptr
           invoke anObject "getValue" returning compareValue
           invoke self "greaterThanOrEqualbyLengthValue" using numChars
                                                        compareValue
                                              returning lnkBool
           invoke self "dealloc" using aptr
           exit method.
       end method "greaterThanOrEqual".
      *>----------------------------------------------------------------
      *> Return true if this intrinsic is less than or equal to the
      *> intrinsic (described by compareLength and compareValue)
      *> otherwise return false.
      *>----------------------------------------------------------------
       method-id. "lessThanOrEqualByLengthValue".
       linkage section.
       01 comparevalue.
           03 aByte pic x occurs 1 to maxNumberBytes
                               depending on compareLength.
       01 bool                 pic x comp-5.
           88 istrue   value 1.
           88 isfalse  value 0.
       01 comparelength        pic s9(9) comp-5.

       procedure division using comparelength comparevalue
                                         returning bool.

           invoke self "lessThanByLengthValue" using comparelength
                                                       comparevalue
                                                    returning bool
           if isfalse
               invoke self "EqualByLengthValue" using comparelength
                                                       comparevalue
                                                    returning bool
           end-if
           exit method.
       end method "lessThanOrEqualByLengthValue".
      *>----------------------------------------------------------------
      *> Return true if this intrinsic is greater than or equal to the
      *> intrinsic (described by compareLength and compareValue)
      *> otherwise return false.
      *>----------------------------------------------------------------
       method-id. "greaterThanOrEqualByLengthValue".
       linkage section.
       01 comparevalue.
           03 aByte pic x occurs 1 to maxNumberBytes
                               depending on compareLength.
       01 bool                 pic x comp-5.
           88 istrue   value 1.
           88 isfalse  value 0.
       01 comparelength        pic s9(9) comp-5.

       procedure division using comparelength comparevalue
                                         returning bool.

           invoke self "greaterThanByLengthValue" using comparelength
                                                        comparevalue
                                                    returning bool
           if isfalse
               invoke self "EqualByLengthValue" using comparelength
                                                      comparevalue
                                                    returning bool
           end-if
           exit method.
       end method "greaterThanOrEqualByLengthValue".
      *>----------------------------------------------------------------
      *> Return the value as the description for this intrinsic
      *>----------------------------------------------------------------
       method-id. "description".
       linkage section.
       01 astring        usage object reference.
       procedure division returning aString.
           invoke self "asCharacterArray" returning astring
           exit method.
       end method "description".



      *>----------------------------------------------------------------
      *> Return true is this object is an indexed instance
      *>----------------------------------------------------------------
       method-id. "isIndexed".
       linkage section.
       01 lnkbool               pic x comp-5.
       procedure division returning lnkbool.
           move 1 to lnkBool
           exit method.
       end method "isIndexed".
      *>----------------------------------------------------------------
      *> Return true is this object is a component.
      *>----------------------------------------------------------------
       method-id. "isComponent".
       linkage section.
       01 lnkbool               pic x comp-5.
       procedure division returning lnkbool.
           move 0 to lnkBool
           exit method.
       end method "isComponent".

      *>----------------------------------------------------------------
      *> Return the length in bytes of this intrinsic
      *>----------------------------------------------------------------
       method-id. "sizeInBytes".
       linkage section.
       01 alength        pic s9(9) comp-5.

       procedure division returning alength.
           invoke selfclass "sizeInBytes" returning alength
           exit method.
       end method "sizeInBytes".

      *>----------------------------------------------------------------
      *> Returns the address of this Intrinsic
      *>----------------------------------------------------------------
       method-id. "getAddress".
       linkage section.
       01 lnkPtr        POINTER.
       procedure division returning lnkPtr.
           set lnkPtr to address of instancedata
           exit method.
       end method "getAddress".

       end object.
       end class intrinsic.
