HW10_95a INTRODUCTION TO Ada I Access Types Part 2 To define a type that has a variable size part it is often convenient to use an access type. The samples following show: 1) A dynamic string package 2) An infinite precision integer definition and a few operators Once an access type is defined then objects may be created using "new" followed by a type mark or qualified expression. This is known as allocating. Ada does not allow an existing object to acquire a pointer to it. Given an object P that is an access type, the data structure that is pointed to is obtained by P.all . This is known as dereferencing. package DString_Pkg is type DString is private; Null_DString : constant DString; function Len (Item : DString) return Natural; function Str (Item : DString) return String; function Equals (Left, Right : DString) return Boolean; function Equals (Left : String; Right : DString) return Boolean; function Equals (Left : DString; Right : String) return Boolean; function "&" (Left, Right : DString) return DString; function "&" (Left : String; Right : DString) return DString; function "&" (Left : DString; Right : String) return DString; function "&" (Left : DString; Right : Character) return DString; function "&" (Left : Character; Right : DString) return DString; function "<" (Left, Right : DString) return Boolean; function "<=" (Left, Right : DString) return Boolean; function ">" (Left, Right : DString) return Boolean; function ">=" (Left, Right : DString) return Boolean; function Allocate (Item : String) return DString; procedure Deallocate (Item : in out DString); pragma Inline (Len, Equals, "&", "<", "<=", ">", ">=", Allocate, Deallocate); private __ type String is array ( Positive range <> ) of Character ; type DString is access String; Null_DString : constant DString := null; end DString_Pkg; with Unchecked_Deallocation; package body DString_Pkg is -- just a fragment function Len (Item : DString) return Natural is begin if Item = Null_Dstring then return 0; else return Item'Length; end if; end Len; function Str (Item : DString) return String is begin if Item = null then return ""; else return Item.All; end if; end Str; function Allocate (Item : String) return DString is begin return new String'(Item); end Allocate; ... Sample use: Object : DString : Allocate ( "Hello there" ) ; begin Object := Object & Object ; package PRECISE_ARITHMETIC is -- stripped down sample from ADA$WLIB -- This package defines the type PRECISE for automatically sized integers. -- There is no limit on the size of integer except when memory runs out. -- -- The operations + - * / ** rem mod +(unary) -(unary) are defined -- -- Comparison operators > >= < <= are defined -- = and /= must be used with ".all" dereferencing -- type PRECISE_ARRAY is array ( INTEGER range <> ) of INTEGER ; type PRECISE_SIGN is ( PLUS , MINUS ) ; type PRECISE_RECORD ( TERMS : INTEGER ) is record SIGN : PRECISE_SIGN := PLUS ; TERM : PRECISE_ARRAY ( 0..TERMS ) := ( 0..TERMS => 0 ) ; end record ; ------------------------------------------------------------------------- -- type PRECISE is access PRECISE_RECORD ; -- -- ------------------------------------------------------------------------- PRECISE_BASE : constant := 10000 ; PRECISE_ZERO : constant PRECISE := new PRECISE_RECORD'(TERMS=>0 , SIGN=>PLUS , TERM =>(0..0=>0)) ; function "+" ( LEFT , RIGHT : PRECISE ) return PRECISE ; function "-" ( LEFT , RIGHT : PRECISE ) return PRECISE ; function "*" ( LEFT , RIGHT : PRECISE ) return PRECISE ; Just a code fragment to show some data structure usage; function "+" ( LEFT , RIGHT : PRECISE ) return PRECISE is LEFT_SIGN : PRECISE_SIGN := LEFT.SIGN ; RIGHT_SIGN : PRECISE_SIGN := RIGHT.SIGN ; CARRY : INTEGER := 0 ; begin if LEFT_SIGN = RIGHT_SIGN then declare RESULT : PRECISE := new PRECISE_RECORD ( MAX( RIGHT.TERM'LAST , LEFT.TERM'LAST ) + 1) ; begin RESULT.SIGN := LEFT_SIGN ; if GREATER_MAGNITUDE ( LEFT , RIGHT ) then RESULT.TERM := ( 0 .. RESULT.TERMS => 0) ; RESULT.TERM ( LEFT.TERM'RANGE ) := LEFT.TERM ; RESULT.SIGN := LEFT_SIGN ; for I in RESULT.TERM'RANGE loop if I <= RIGHT.TERM'LAST then RESULT.TERM ( I ) := RESULT.TERM ( I ) + RIGHT.TERM ( I ) ; end if ; RESULT.TERM ( I ) := RESULT.TERM ( I ) + CARRY ; if RESULT.TERM ( I ) >= BASE then RESULT.TERM ( I ) := RESULT.TERM ( I ) - BASE ; CARRY := 1 ; else CARRY := 0 ; end if ; end loop ; else ... end if ; return TRIM ( RESULT ) ; end ; elsif LEFT_SIGN = PLUS and RIGHT_SIGN = MINUS then declare NEW_RIGHT : PRECISE := new PRECISE_RECORD ( RIGHT.TERMS ) ; begin NEW_RIGHT.all := RIGHT.all ; NEW_RIGHT.SIGN := PLUS ; return LEFT - NEW_RIGHT ; end ; else ... end if ; end "+" ; A few more sample functions: function "abs" ( RIGHT : PRECISE ) return PRECISE is RESULT : PRECISE := new PRECISE_RECORD ( RIGHT.TERMS ) ; begin RESULT.all := RIGHT.all ; -- COPY IT IN, CAN'T POINT TO EXISTING !!!!!!!! RESULT.SIGN := PLUS ; -- SET ONLY SIGN IN RECORD !!!!!!!!!!!!!!!!!!!! return TRIM ( RESULT ) ; end "abs" ; function ">=" ( LEFT , RIGHT : PRECISE ) return BOOLEAN is begin if LEFT.all = RIGHT.all then -- NOTE TEST FOR EQUALITY !!!!!!!!!!!!!!!! -- NOT LEFT = RIGHT i.e. same pointer return TRUE ; else return LEFT > RIGHT ; end if ; end ">=" ; function INTEGER_TO_PRECISE ( ITEM : INTEGER ) return PRECISE is REDUCE : INTEGER := abs ITEM ; TERMS : INTEGER := 0 ; begin loop REDUCE := REDUCE / BASE ; exit when REDUCE = 0 ; TERMS := TERMS + 1 ; end loop ; REDUCE := abs ITEM ; declare RESULT : PRECISE := new PRECISE_RECORD ( TERMS ) ; begin for I in 0 .. TERMS loop RESULT.TERM ( I ) := REDUCE mod BASE ; REDUCE := REDUCE / BASE ; end loop ; RESULT.SIGN := PLUS ; if ITEM < 0 then RESULT.SIGN := MINUS ; end if ; return TRIM ( RESULT ) ; end ; end INTEGER_TO_PRECISE ; Some sample usage: with TEXT_IO ; use TEXT_IO ; with PRECISE_ARITHMETIC ; use PRECISE_ARITHMETIC ; procedure TEST_PRECISE_ARITHMETIC is P101 : PRECISE := INTEGER_TO_PRECISE ( 101 ) ; P51 : PRECISE := INTEGER_TO_PRECISE ( 51 ) ; M101 : PRECISE := INTEGER_TO_PRECISE ( -101 ) ; M51 : PRECISE := INTEGER_TO_PRECISE ( -51 ) ; SUM : PRECISE ; DIFF : PRECISE ; PROD : PRECISE ; QUO : PRECISE ; REMAIN : PRECISE ; MODULO : PRECISE ; begin PUT ( P101 ** 10 ) ; PUT_LINE ( " = P101 ** 10 " ) ; -- SUM := P101 + P51 ; DIFF := P101 - P51 ; PROD := P101 * P51 ; QUO := P101 / P51 ; REMAIN := P101 rem P51 ; MODULO := P101 mod P51 ; PROD := P101 - ( QUO * P51 + REMAIN ) ; PUT ( PROD ) ; PUT_LINE ( " = PROD " ) ; end;