1----------------------------------------------------------------------- 2-- Util.Beans.Objects -- Generic Typed Data Representation 3-- Copyright (C) 2009, 2010, 2011, 2013 Stephane Carrez 4-- Written by Stephane Carrez (Stephane.Carrez@gmail.com) 5-- 6-- Licensed under the Apache License, Version 2.0 (the "License"); 7-- you may not use this file except in compliance with the License. 8-- You may obtain a copy of the License at 9-- 10-- http://www.apache.org/licenses/LICENSE-2.0 11-- 12-- Unless required by applicable law or agreed to in writing, software 13-- distributed under the License is distributed on an "AS IS" BASIS, 14-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 15-- See the License for the specific language governing permissions and 16-- limitations under the License. 17----------------------------------------------------------------------- 18 19with Ada.Characters.Conversions; 20with Ada.Unchecked_Deallocation; 21with Interfaces.C; 22with Util.Beans.Basic; 23package body Util.Beans.Objects is 24 25 use Util.Concurrent.Counters; 26 use Ada.Characters.Conversions; 27 28 use type Interfaces.C.long; 29 30 -- Find the data type to be used for an arithmetic operation between two objects. 31 function Get_Arithmetic_Type (Left, Right : Object) return Data_Type; 32 33 -- Find the data type to be used for a composition operation between two objects. 34 function Get_Compose_Type (Left, Right : Object) return Data_Type; 35 36 -- Find the best type to be used to compare two operands. 37 function Get_Compare_Type (Left, Right : Object) return Data_Type; 38 39 Integer_Type : aliased constant Int_Type := Int_Type '(others => <>); 40 Bool_Type : aliased constant Boolean_Type := Boolean_Type '(others => <>); 41 Str_Type : aliased constant String_Type := String_Type '(others => <>); 42 WString_Type : aliased constant Wide_String_Type := Wide_String_Type '(others => <>); 43 Flt_Type : aliased constant Float_Type := Float_Type '(others => <>); 44 Duration_Type : aliased constant Duration_Type_Def := Duration_Type_Def '(others => <>); 45 Bn_Type : aliased constant Bean_Type := Bean_Type '(others => <>); 46 47 -- ------------------------------ 48 -- Convert the value into a wide string. 49 -- ------------------------------ 50 function To_Wide_Wide_String (Type_Def : in Basic_Type; 51 Value : in Object_Value) return Wide_Wide_String is 52 begin 53 return To_Wide_Wide_String (Object_Type'Class (Type_Def).To_String (Value)); 54 end To_Wide_Wide_String; 55 56 -- ------------------------------ 57 -- Convert the value into a float. 58 -- ------------------------------ 59 function To_Long_Float (Type_Def : in Basic_Type; 60 Value : in Object_Value) return Long_Long_Float is 61 pragma Unreferenced (Type_Def, Value); 62 begin 63 return 0.0; 64 end To_Long_Float; 65 66 -- ------------------------------ 67 -- Convert the value into a boolean. 68 -- ------------------------------ 69 function To_Boolean (Type_Def : in Basic_Type; 70 Value : in Object_Value) return Boolean is 71 pragma Unreferenced (Type_Def, Value); 72 begin 73 return False; 74 end To_Boolean; 75 76 -- ------------------------------ 77 -- Convert the value into a duration. 78 -- ------------------------------ 79 function To_Duration (Type_Def : in Basic_Type; 80 Value : in Object_Value) return Duration is 81 pragma Unreferenced (Type_Def, Value); 82 begin 83 return 0.0; 84 end To_Duration; 85 86 -- ------------------------------ 87 -- Returns False 88 -- ------------------------------ 89 function Is_Empty (Type_Def : in Basic_Type; 90 Value : in Object_Value) return Boolean is 91 pragma Unreferenced (Type_Def, Value); 92 begin 93 return False; 94 end Is_Empty; 95 96 -- ------------------------------ 97 -- Null Type 98 -- ------------------------------ 99 100 -- ------------------------------ 101 -- Get the type name 102 -- ------------------------------ 103 function Get_Name (Type_Def : Null_Type) return String is 104 pragma Unreferenced (Type_Def); 105 begin 106 return "Null"; 107 end Get_Name; 108 109 -- ------------------------------ 110 -- Get the base data type. 111 -- ------------------------------ 112 function Get_Data_Type (Type_Def : Null_Type) return Data_Type is 113 pragma Unreferenced (Type_Def); 114 begin 115 return TYPE_NULL; 116 end Get_Data_Type; 117 118 -- ------------------------------ 119 -- Convert the value into a string. 120 -- ------------------------------ 121 function To_String (Type_Def : in Null_Type; 122 Value : in Object_Value) return String is 123 pragma Unreferenced (Type_Def, Value); 124 begin 125 return "null"; 126 end To_String; 127 128 -- ------------------------------ 129 -- Returns True 130 -- ------------------------------ 131 function Is_Empty (Type_Def : in Null_Type; 132 Value : in Object_Value) return Boolean is 133 pragma Unreferenced (Type_Def, Value); 134 begin 135 return True; 136 end Is_Empty; 137 138 -- ------------------------------ 139 -- Integer Type 140 -- ------------------------------ 141 142 -- ------------------------------ 143 -- Get the type name 144 -- ------------------------------ 145 function Get_Name (Type_Def : Int_Type) return String is 146 pragma Unreferenced (Type_Def); 147 begin 148 return "Integer"; 149 end Get_Name; 150 151 -- ------------------------------ 152 -- Get the base data type. 153 -- ------------------------------ 154 function Get_Data_Type (Type_Def : Int_Type) return Data_Type is 155 pragma Unreferenced (Type_Def); 156 begin 157 return TYPE_INTEGER; 158 end Get_Data_Type; 159 160 -- ------------------------------ 161 -- Convert the value into a string. 162 -- ------------------------------ 163 function To_String (Type_Def : in Int_Type; 164 Value : in Object_Value) return String is 165 pragma Unreferenced (Type_Def); 166 167 S : constant String := Long_Long_Integer'Image (Value.Int_Value); 168 begin 169 if Value.Int_Value >= 0 then 170 return S (S'First + 1 .. S'Last); 171 else 172 return S; 173 end if; 174 end To_String; 175 176 -- ------------------------------ 177 -- Convert the value into an integer. 178 -- ------------------------------ 179 function To_Long_Long (Type_Def : in Int_Type; 180 Value : in Object_Value) return Long_Long_Integer is 181 pragma Unreferenced (Type_Def); 182 begin 183 return Value.Int_Value; 184 end To_Long_Long; 185 186 -- ------------------------------ 187 -- Convert the value into a float. 188 -- ------------------------------ 189 function To_Long_Float (Type_Def : in Int_Type; 190 Value : in Object_Value) return Long_Long_Float is 191 pragma Unreferenced (Type_Def); 192 begin 193 return Long_Long_Float (Value.Int_Value); 194 end To_Long_Float; 195 196 -- ------------------------------ 197 -- Convert the value into a boolean. 198 -- ------------------------------ 199 function To_Boolean (Type_Def : in Int_Type; 200 Value : in Object_Value) return Boolean is 201 pragma Unreferenced (Type_Def); 202 begin 203 return Value.Int_Value /= 0; 204 end To_Boolean; 205 206 -- ------------------------------ 207 -- Convert the value into a duration. 208 -- ------------------------------ 209 function To_Duration (Type_Def : in Int_Type; 210 Value : in Object_Value) return Duration is 211 pragma Unreferenced (Type_Def); 212 begin 213 return Duration (Value.Int_Value); 214 end To_Duration; 215 216 -- ------------------------------ 217 -- Float Type 218 -- ------------------------------ 219 220 -- ------------------------------ 221 -- Get the type name 222 -- ------------------------------ 223 function Get_Name (Type_Def : in Float_Type) return String is 224 pragma Unreferenced (Type_Def); 225 begin 226 return "Float"; 227 end Get_Name; 228 229 -- ------------------------------ 230 -- Get the base data type. 231 -- ------------------------------ 232 function Get_Data_Type (Type_Def : in Float_Type) return Data_Type is 233 pragma Unreferenced (Type_Def); 234 begin 235 return TYPE_FLOAT; 236 end Get_Data_Type; 237 238 -- ------------------------------ 239 -- Convert the value into a string. 240 -- ------------------------------ 241 function To_String (Type_Def : in Float_Type; 242 Value : in Object_Value) return String is 243 pragma Unreferenced (Type_Def); 244 begin 245 return Long_Long_Float'Image (Value.Float_Value); 246 end To_String; 247 248 -- ------------------------------ 249 -- Convert the value into an integer. 250 -- ------------------------------ 251 function To_Long_Long (Type_Def : in Float_Type; 252 Value : in Object_Value) return Long_Long_Integer is 253 pragma Unreferenced (Type_Def); 254 begin 255 return Long_Long_Integer (Value.Float_Value); 256 end To_Long_Long; 257 258 -- ------------------------------ 259 -- Convert the value into a float. 260 -- ------------------------------ 261 function To_Long_Float (Type_Def : in Float_Type; 262 Value : in Object_Value) return Long_Long_Float is 263 pragma Unreferenced (Type_Def); 264 begin 265 return Value.Float_Value; 266 end To_Long_Float; 267 268 -- ------------------------------ 269 -- Convert the value into a boolean. 270 -- ------------------------------ 271 function To_Boolean (Type_Def : in Float_Type; 272 Value : in Object_Value) return Boolean is 273 pragma Unreferenced (Type_Def); 274 begin 275 return Value.Float_Value /= 0.0; 276 end To_Boolean; 277 278 -- ------------------------------ 279 -- Convert the value into a duration. 280 -- ------------------------------ 281 function To_Duration (Type_Def : in Float_Type; 282 Value : in Object_Value) return Duration is 283 pragma Unreferenced (Type_Def); 284 begin 285 return Duration (Value.Float_Value); 286 end To_Duration; 287 288 -- ------------------------------ 289 -- String Type 290 -- ------------------------------ 291 292 -- ------------------------------ 293 -- Get the type name 294 -- ------------------------------ 295 function Get_Name (Type_Def : in String_Type) return String is 296 pragma Unreferenced (Type_Def); 297 begin 298 return "String"; 299 end Get_Name; 300 301 -- ------------------------------ 302 -- Get the base data type. 303 -- ------------------------------ 304 function Get_Data_Type (Type_Def : in String_Type) return Data_Type is 305 pragma Unreferenced (Type_Def); 306 begin 307 return TYPE_STRING; 308 end Get_Data_Type; 309 310 -- ------------------------------ 311 -- Convert the value into a string. 312 -- ------------------------------ 313 function To_String (Type_Def : in String_Type; 314 Value : in Object_Value) return String is 315 pragma Unreferenced (Type_Def); 316 Proxy : constant String_Proxy_Access := Value.String_Proxy; 317 begin 318 if Proxy = null then 319 return "null"; 320 else 321 return Proxy.Value; 322 end if; 323 end To_String; 324 325 -- ------------------------------ 326 -- Convert the value into an integer. 327 -- ------------------------------ 328 function To_Long_Long (Type_Def : in String_Type; 329 Value : in Object_Value) return Long_Long_Integer is 330 pragma Unreferenced (Type_Def); 331 Proxy : constant String_Proxy_Access := Value.String_Proxy; 332 begin 333 if Proxy = null then 334 return 0; 335 else 336 return Long_Long_Integer'Value (Proxy.Value); 337 end if; 338 end To_Long_Long; 339 340 -- ------------------------------ 341 -- Convert the value into a float. 342 -- ------------------------------ 343 function To_Long_Float (Type_Def : in String_Type; 344 Value : in Object_Value) return Long_Long_Float is 345 pragma Unreferenced (Type_Def); 346 Proxy : constant String_Proxy_Access := Value.String_Proxy; 347 begin 348 if Proxy = null then 349 return 0.0; 350 else 351 return Long_Long_Float'Value (Proxy.Value); 352 end if; 353 end To_Long_Float; 354 355 -- ------------------------------ 356 -- Convert the value into a boolean. 357 -- ------------------------------ 358 function To_Boolean (Type_Def : in String_Type; 359 Value : in Object_Value) return Boolean is 360 pragma Unreferenced (Type_Def); 361 Proxy : constant String_Proxy_Access := Value.String_Proxy; 362 begin 363 return Proxy /= null 364 and then (Proxy.Value = "true" 365 or Proxy.Value = "TRUE" 366 or Proxy.Value = "1"); 367 end To_Boolean; 368 369 -- ------------------------------ 370 -- Returns True if the value is empty. 371 -- ------------------------------ 372 function Is_Empty (Type_Def : in String_Type; 373 Value : in Object_Value) return Boolean is 374 pragma Unreferenced (Type_Def); 375 Proxy : constant String_Proxy_Access := Value.String_Proxy; 376 begin 377 return Proxy = null or else Proxy.Value = ""; 378 end Is_Empty; 379 380 -- ------------------------------ 381 -- Convert the value into a duration. 382 -- ------------------------------ 383 function To_Duration (Type_Def : in String_Type; 384 Value : in Object_Value) return Duration is 385 pragma Unreferenced (Type_Def); 386 begin 387 if Value.Proxy = null then 388 return 0.0; 389 else 390 return Duration'Value (String_Proxy (Value.Proxy.all).Value); 391 end if; 392 end To_Duration; 393 394 -- ------------------------------ 395 -- Wide String Type 396 -- ------------------------------ 397 398 -- ------------------------------ 399 -- Get the type name 400 -- ------------------------------ 401 function Get_Name (Type_Def : in Wide_String_Type) return String is 402 pragma Unreferenced (Type_Def); 403 begin 404 return "WideString"; 405 end Get_Name; 406 407 -- ------------------------------ 408 -- Get the base data type. 409 -- ------------------------------ 410 function Get_Data_Type (Type_Def : in Wide_String_Type) return Data_Type is 411 pragma Unreferenced (Type_Def); 412 begin 413 return TYPE_WIDE_STRING; 414 end Get_Data_Type; 415 416 -- ------------------------------ 417 -- Convert the value into a string. 418 -- ------------------------------ 419 function To_String (Type_Def : in Wide_String_Type; 420 Value : in Object_Value) return String is 421 pragma Unreferenced (Type_Def); 422 Proxy : constant Wide_String_Proxy_Access := Value.Wide_Proxy; 423 begin 424 if Proxy = null then 425 return "null"; 426 else 427 return To_String (Proxy.Value); 428 end if; 429 end To_String; 430 431 -- ------------------------------ 432 -- Convert the value into a wide string. 433 -- ------------------------------ 434 function To_Wide_Wide_String (Type_Def : in Wide_String_Type; 435 Value : in Object_Value) return Wide_Wide_String is 436 pragma Unreferenced (Type_Def); 437 Proxy : constant Wide_String_Proxy_Access := Value.Wide_Proxy; 438 begin 439 if Proxy = null then 440 return "null"; 441 else 442 return Proxy.Value; 443 end if; 444 end To_Wide_Wide_String; 445 446 -- ------------------------------ 447 -- Convert the value into an integer. 448 -- ------------------------------ 449 function To_Long_Long (Type_Def : in Wide_String_Type; 450 Value : in Object_Value) return Long_Long_Integer is 451 pragma Unreferenced (Type_Def); 452 Proxy : constant Wide_String_Proxy_Access := Value.Wide_Proxy; 453 begin 454 if Proxy = null then 455 return 0; 456 else 457 return Long_Long_Integer'Value (To_String (Proxy.Value)); 458 end if; 459 end To_Long_Long; 460 461 -- ------------------------------ 462 -- Convert the value into a float. 463 -- ------------------------------ 464 function To_Long_Float (Type_Def : in Wide_String_Type; 465 Value : in Object_Value) return Long_Long_Float is 466 pragma Unreferenced (Type_Def); 467 Proxy : constant Wide_String_Proxy_Access := Value.Wide_Proxy; 468 begin 469 if Proxy = null then 470 return 0.0; 471 else 472 return Long_Long_Float'Value (To_String (Proxy.Value)); 473 end if; 474 end To_Long_Float; 475 476 -- ------------------------------ 477 -- Convert the value into a boolean. 478 -- ------------------------------ 479 function To_Boolean (Type_Def : in Wide_String_Type; 480 Value : in Object_Value) return Boolean is 481 pragma Unreferenced (Type_Def); 482 Proxy : constant Wide_String_Proxy_Access := Value.Wide_Proxy; 483 begin 484 return Proxy /= null 485 and then (Proxy.Value = "true" 486 or Proxy.Value = "TRUE" 487 or Proxy.Value = "1"); 488 end To_Boolean; 489 490 -- ------------------------------ 491 -- Convert the value into a duration. 492 -- ------------------------------ 493 function To_Duration (Type_Def : in Wide_String_Type; 494 Value : in Object_Value) return Duration is 495 pragma Unreferenced (Type_Def); 496 Proxy : constant Wide_String_Proxy_Access := Value.Wide_Proxy; 497 begin 498 if Proxy = null then 499 return 0.0; 500 else 501 return Duration'Value (To_String (Proxy.Value)); 502 end if; 503 end To_Duration; 504 505 -- ------------------------------ 506 -- Returns True if the value is empty. 507 -- ------------------------------ 508 function Is_Empty (Type_Def : in Wide_String_Type; 509 Value : in Object_Value) return Boolean is 510 pragma Unreferenced (Type_Def); 511 Proxy : constant Wide_String_Proxy_Access := Value.Wide_Proxy; 512 begin 513 return Proxy = null or else Proxy.Value = ""; 514 end Is_Empty; 515 516 -- ------------------------------ 517 -- Boolean Type 518 -- ------------------------------ 519 520 -- ------------------------------ 521 -- Get the type name 522 -- ------------------------------ 523 function Get_Name (Type_Def : in Boolean_Type) return String is 524 pragma Unreferenced (Type_Def); 525 begin 526 return "Boolean"; 527 end Get_Name; 528 529 -- ------------------------------ 530 -- Get the base data type. 531 -- ------------------------------ 532 function Get_Data_Type (Type_Def : in Boolean_Type) return Data_Type is 533 pragma Unreferenced (Type_Def); 534 begin 535 return TYPE_BOOLEAN; 536 end Get_Data_Type; 537 538 -- ------------------------------ 539 -- Convert the value into a string. 540 -- ------------------------------ 541 function To_String (Type_Def : in Boolean_Type; 542 Value : in Object_Value) return String is 543 pragma Unreferenced (Type_Def); 544 begin 545 if Value.Bool_Value then 546 return "TRUE"; 547 else 548 return "FALSE"; 549 end if; 550 end To_String; 551 552 -- ------------------------------ 553 -- Convert the value into an integer. 554 -- ------------------------------ 555 function To_Long_Long (Type_Def : in Boolean_Type; 556 Value : in Object_Value) return Long_Long_Integer is 557 pragma Unreferenced (Type_Def); 558 begin 559 if Value.Bool_Value then 560 return 1; 561 else 562 return 0; 563 end if; 564 end To_Long_Long; 565 566 -- ------------------------------ 567 -- Convert the value into a float. 568 -- ------------------------------ 569 function To_Long_Float (Type_Def : in Boolean_Type; 570 Value : in Object_Value) return Long_Long_Float is 571 pragma Unreferenced (Type_Def); 572 begin 573 if Value.Bool_Value then 574 return 1.0; 575 else 576 return 0.0; 577 end if; 578 end To_Long_Float; 579 580 -- ------------------------------ 581 -- Convert the value into a boolean. 582 -- ------------------------------ 583 function To_Boolean (Type_Def : in Boolean_Type; 584 Value : in Object_Value) return Boolean is 585 pragma Unreferenced (Type_Def); 586 begin 587 return Value.Bool_Value; 588 end To_Boolean; 589 590 -- ------------------------------ 591 -- Duration Type 592 -- ------------------------------ 593 594 -- ------------------------------ 595 -- Get the type name 596 -- ------------------------------ 597 function Get_Name (Type_Def : in Duration_Type_Def) return String is 598 pragma Unreferenced (Type_Def); 599 begin 600 return "Duration"; 601 end Get_Name; 602 603 -- ------------------------------ 604 -- Get the base data type. 605 -- ------------------------------ 606 function Get_Data_Type (Type_Def : in Duration_Type_Def) return Data_Type is 607 pragma Unreferenced (Type_Def); 608 begin 609 return TYPE_TIME; 610 end Get_Data_Type; 611 612 -- ------------------------------ 613 -- Convert the value into a string. 614 -- ------------------------------ 615 function To_String (Type_Def : in Duration_Type_Def; 616 Value : in Object_Value) return String is 617 pragma Unreferenced (Type_Def); 618 begin 619 return Duration'Image (Value.Time_Value); 620 end To_String; 621 622 -- ------------------------------ 623 -- Convert the value into an integer. 624 -- ------------------------------ 625 function To_Long_Long (Type_Def : in Duration_Type_Def; 626 Value : in Object_Value) return Long_Long_Integer is 627 pragma Unreferenced (Type_Def); 628 begin 629 return Long_Long_Integer (Value.Time_Value); 630 end To_Long_Long; 631 632 -- ------------------------------ 633 -- Convert the value into a float. 634 -- ------------------------------ 635 function To_Long_Float (Type_Def : in Duration_Type_Def; 636 Value : in Object_Value) return Long_Long_Float is 637 pragma Unreferenced (Type_Def); 638 begin 639 return Long_Long_Float (Value.Time_Value); 640 end To_Long_Float; 641 642 -- ------------------------------ 643 -- Convert the value into a boolean. 644 -- ------------------------------ 645 function To_Boolean (Type_Def : in Duration_Type_Def; 646 Value : in Object_Value) return Boolean is 647 pragma Unreferenced (Type_Def); 648 begin 649 return Value.Time_Value > 0.0; 650 end To_Boolean; 651 652 -- ------------------------------ 653 -- Convert the value into a duration. 654 -- ------------------------------ 655 function To_Duration (Type_Def : in Duration_Type_Def; 656 Value : in Object_Value) return Duration is 657 pragma Unreferenced (Type_Def); 658 begin 659 return Value.Time_Value; 660 end To_Duration; 661 662 -- ------------------------------ 663 -- Bean Type 664 -- ------------------------------ 665 666 -- ------------------------------ 667 -- Get the type name 668 -- ------------------------------ 669 function Get_Name (Type_Def : in Bean_Type) return String is 670 pragma Unreferenced (Type_Def); 671 begin 672 return "Bean"; 673 end Get_Name; 674 675 -- ------------------------------ 676 -- Get the base data type. 677 -- ------------------------------ 678 function Get_Data_Type (Type_Def : in Bean_Type) return Data_Type is 679 pragma Unreferenced (Type_Def); 680 begin 681 return TYPE_BEAN; 682 end Get_Data_Type; 683 684 -- ------------------------------ 685 -- Convert the value into a string. 686 -- ------------------------------ 687 function To_String (Type_Def : in Bean_Type; 688 Value : in Object_Value) return String is 689 pragma Unreferenced (Type_Def, Value); 690 begin 691 return "<bean>"; 692 end To_String; 693 694 -- ------------------------------ 695 -- Convert the value into an integer. 696 -- ------------------------------ 697 function To_Long_Long (Type_Def : in Bean_Type; 698 Value : in Object_Value) return Long_Long_Integer is 699 pragma Unreferenced (Type_Def, Value); 700 begin 701 return 0; 702 end To_Long_Long; 703 704 -- ------------------------------ 705 -- Convert the value into a float. 706 -- ------------------------------ 707 function To_Long_Float (Type_Def : in Bean_Type; 708 Value : in Object_Value) return Long_Long_Float is 709 pragma Unreferenced (Type_Def, Value); 710 begin 711 return 0.0; 712 end To_Long_Float; 713 714 -- ------------------------------ 715 -- Convert the value into a boolean. 716 -- ------------------------------ 717 function To_Boolean (Type_Def : in Bean_Type; 718 Value : in Object_Value) return Boolean is 719 pragma Unreferenced (Type_Def); 720 Proxy : constant Bean_Proxy_Access := Value.Proxy; 721 begin 722 return Proxy /= null; 723 end To_Boolean; 724 725 -- ------------------------------ 726 -- Returns True if the value is empty. 727 -- ------------------------------ 728 function Is_Empty (Type_Def : in Bean_Type; 729 Value : in Object_Value) return Boolean is 730 pragma Unreferenced (Type_Def); 731 Proxy : constant Bean_Proxy_Access := Value.Proxy; 732 begin 733 if Proxy = null then 734 return True; 735 end if; 736 if not (Proxy.all in Bean_Proxy'Class) then 737 return False; 738 end if; 739 if not (Bean_Proxy (Proxy.all).Bean.all in Util.Beans.Basic.List_Bean'Class) then 740 return False; 741 end if; 742 declare 743 L : constant Util.Beans.Basic.List_Bean_Access := 744 Beans.Basic.List_Bean'Class (Bean_Proxy (Proxy.all).Bean.all)'Unchecked_Access; 745 begin 746 return L.Get_Count = 0; 747 end; 748 end Is_Empty; 749 750 -- ------------------------------ 751 -- Convert the value into a string. 752 -- ------------------------------ 753 function To_Long_Long (Type_Def : in Basic_Type; 754 Value : in Object_Value) return Long_Long_Integer is 755 pragma Unreferenced (Type_Def, Value); 756 begin 757 return 0; 758 end To_Long_Long; 759 760 -- ------------------------------ 761 -- Check whether the object contains a value. 762 -- Returns true if the object does not contain a value. 763 -- ------------------------------ 764 function Is_Null (Value : in Object) return Boolean is 765 begin 766 return Value.V.Of_Type = TYPE_NULL; 767 end Is_Null; 768 769 -- ------------------------------ 770 -- Check whether the object is empty. 771 -- If the object is null, returns true. 772 -- If the object is the empty string, returns true. 773 -- If the object is a list bean whose Get_Count is 0, returns true. 774 -- Otherwise returns false. 775 -- ------------------------------ 776 function Is_Empty (Value : in Object) return Boolean is 777 begin 778 return Value.Type_Def.Is_Empty (Value.V); 779 end Is_Empty; 780 781 -- ------------------------------ 782 -- Generic Object holding a value 783 -- ------------------------------ 784 785 -- ------------------------------ 786 -- Get the type name 787 -- ------------------------------ 788 function Get_Type_Name (Value : in Object) return String is 789 begin 790 return Value.Type_Def.Get_Name; 791 end Get_Type_Name; 792 793 -- ------------------------------ 794 -- Get a type identification for the object value. 795 -- ------------------------------ 796 function Get_Type (Value : in Object) return Data_Type is 797 begin 798 return Value.V.Of_Type; 799 end Get_Type; 800 801 -- ------------------------------ 802 -- Get the type definition of the object value. 803 -- ------------------------------ 804 function Get_Type (Value : Object) return Object_Type_Access is 805 begin 806 return Value.Type_Def; 807 end Get_Type; 808 809 -- ------------------------------ 810 -- Get the value identified by the name in the bean object. 811 -- If the value object is not a bean, returns the null object. 812 -- ------------------------------ 813 function Get_Value (Value : in Object; 814 Name : in String) return Object is 815 Bean : constant access Util.Beans.Basic.Readonly_Bean'Class := To_Bean (Value); 816 begin 817 if Bean = null then 818 return Null_Object; 819 else 820 return Bean.Get_Value (Name); 821 end if; 822 end Get_Value; 823 824 -- ------------------------------ 825 -- Convert the object to the corresponding type. 826 -- ------------------------------ 827 function To_String (Value : Object) return String is 828 begin 829 return Value.Type_Def.To_String (Value.V); 830 end To_String; 831 832 -- ------------------------------ 833 -- Convert the object to a wide string. 834 -- ------------------------------ 835 function To_Wide_Wide_String (Value : Object) return Wide_Wide_String is 836 begin 837 return Value.Type_Def.To_Wide_Wide_String (Value.V); 838 end To_Wide_Wide_String; 839 840 -- ------------------------------ 841 -- Convert the object to an unbounded string. 842 -- ------------------------------ 843 function To_Unbounded_String (Value : Object) return Unbounded_String is 844 begin 845 case Value.V.Of_Type is 846 when TYPE_STRING => 847 if Value.V.String_Proxy = null then 848 return To_Unbounded_String ("null"); 849 end if; 850 return To_Unbounded_String (Value.V.String_Proxy.Value); 851 852 when others => 853 return To_Unbounded_String (To_String (Value)); 854 855 end case; 856 end To_Unbounded_String; 857 858 -- ------------------------------ 859 -- Convert the object to an unbounded wide string. 860 -- ------------------------------ 861 function To_Unbounded_Wide_Wide_String (Value : Object) return Unbounded_Wide_Wide_String is 862 begin 863 case Value.V.Of_Type is 864 when TYPE_WIDE_STRING => 865 if Value.V.Wide_Proxy = null then 866 return To_Unbounded_Wide_Wide_String ("null"); 867 end if; 868 return To_Unbounded_Wide_Wide_String (Value.V.Wide_Proxy.Value); 869 870 when TYPE_STRING => 871 if Value.V.String_Proxy = null then 872 return To_Unbounded_Wide_Wide_String ("null"); 873 end if; 874 return To_Unbounded_Wide_Wide_String 875 (To_Wide_Wide_String (Value.V.String_Proxy.Value)); 876 877 when others => 878 return To_Unbounded_Wide_Wide_String (To_Wide_Wide_String (To_String (Value))); 879 880 end case; 881 end To_Unbounded_Wide_Wide_String; 882 883 -- ------------------------------ 884 -- Convert the object to an integer. 885 -- ------------------------------ 886 function To_Integer (Value : Object) return Integer is 887 begin 888 return Integer (Value.Type_Def.To_Long_Long (Value.V)); 889 end To_Integer; 890 891 -- ------------------------------ 892 -- Convert the object to an integer. 893 -- ------------------------------ 894 function To_Long_Integer (Value : Object) return Long_Integer is 895 begin 896 return Long_Integer (Value.Type_Def.To_Long_Long (Value.V)); 897 end To_Long_Integer; 898 899 -- ------------------------------ 900 -- Convert the object to a long integer. 901 -- ------------------------------ 902 function To_Long_Long_Integer (Value : Object) return Long_Long_Integer is 903 begin 904 return Value.Type_Def.To_Long_Long (Value.V); 905 end To_Long_Long_Integer; 906 907 -- ------------------------------ 908 -- Convert the object to a duration. 909 -- ------------------------------ 910 function To_Duration (Value : in Object) return Duration is 911 begin 912 return Value.Type_Def.To_Duration (Value.V); 913 end To_Duration; 914 915 function To_Bean (Value : in Object) return access Util.Beans.Basic.Readonly_Bean'Class is 916-- Proxy : constant Bean_Proxy_Access; 917 begin 918 if Value.V.Of_Type = TYPE_BEAN and then Value.V.Proxy /= null then 919 return Bean_Proxy (Value.V.Proxy.all).Bean; 920 else 921 return null; 922 end if; 923 end To_Bean; 924 925 -- ------------------------------ 926 -- Convert the object to a boolean. 927 -- ------------------------------ 928 function To_Boolean (Value : Object) return Boolean is 929 begin 930 return Value.Type_Def.To_Boolean (Value.V); 931 end To_Boolean; 932 933 -- ------------------------------ 934 -- Convert the object to a float. 935 -- ------------------------------ 936 function To_Float (Value : Object) return Float is 937 begin 938 return Float (Value.Type_Def.To_Long_Float (Value.V)); 939 end To_Float; 940 941 -- ------------------------------ 942 -- Convert the object to a long float. 943 -- ------------------------------ 944 function To_Long_Float (Value : Object) return Long_Float is 945 begin 946 return Long_Float (Value.Type_Def.To_Long_Float (Value.V)); 947 end To_Long_Float; 948 949 -- ------------------------------ 950 -- Convert the object to a long float. 951 -- ------------------------------ 952 function To_Long_Long_Float (Value : Object) return Long_Long_Float is 953 begin 954 return Value.Type_Def.To_Long_Float (Value.V); 955 end To_Long_Long_Float; 956 957 -- ------------------------------ 958 -- Convert an integer into a generic typed object. 959 -- ------------------------------ 960 function To_Object (Value : Integer) return Object is 961 begin 962 return Object '(Controlled with 963 V => Object_Value '(Of_Type => TYPE_INTEGER, 964 Int_Value => Long_Long_Integer (Value)), 965 Type_Def => Integer_Type'Access); 966 end To_Object; 967 968 -- ------------------------------ 969 -- Convert an integer into a generic typed object. 970 -- ------------------------------ 971 function To_Object (Value : Long_Integer) return Object is 972 begin 973 return Object '(Controlled with 974 V => Object_Value '(Of_Type => TYPE_INTEGER, 975 Int_Value => Long_Long_Integer (Value)), 976 Type_Def => Integer_Type'Access); 977 end To_Object; 978 979 -- ------------------------------ 980 -- Convert an integer into a generic typed object. 981 -- ------------------------------ 982 function To_Object (Value : Long_Long_Integer) return Object is 983 begin 984 return Object '(Controlled with 985 V => Object_Value '(Of_Type => TYPE_INTEGER, 986 Int_Value => Value), 987 Type_Def => Integer_Type'Access); 988 end To_Object; 989 990 -- ------------------------------ 991 -- Convert a boolean into a generic typed object. 992 -- ------------------------------ 993 function To_Object (Value : Boolean) return Object is 994 begin 995 return Object '(Controlled with 996 V => Object_Value '(Of_Type => TYPE_BOOLEAN, 997 Bool_Value => Value), 998 Type_Def => Bool_Type'Access); 999 end To_Object; 1000 1001 -- ------------------------------ 1002 -- Convert a float into a generic typed object. 1003 -- ------------------------------ 1004 function To_Object (Value : Float) return Object is 1005 begin 1006 return Object '(Controlled with 1007 V => Object_Value '(Of_Type => TYPE_FLOAT, 1008 Float_Value => Long_Long_Float (Value)), 1009 Type_Def => Flt_Type'Access); 1010 end To_Object; 1011 1012 -- ------------------------------ 1013 -- Convert a long float into a generic typed object. 1014 -- ------------------------------ 1015 function To_Object (Value : Long_Float) return Object is 1016 begin 1017 return Object '(Controlled with 1018 V => Object_Value '(Of_Type => TYPE_FLOAT, 1019 Float_Value => Long_Long_Float (Value)), 1020 Type_Def => Flt_Type'Access); 1021 end To_Object; 1022 1023 -- ------------------------------ 1024 -- Convert a long long float into a generic typed object. 1025 -- ------------------------------ 1026 function To_Object (Value : Long_Long_Float) return Object is 1027 begin 1028 return Object '(Controlled with 1029 V => Object_Value '(Of_Type => TYPE_FLOAT, 1030 Float_Value => Value), 1031 Type_Def => Flt_Type'Access); 1032 end To_Object; 1033 1034 -- ------------------------------ 1035 -- Convert a duration into a generic typed object. 1036 -- ------------------------------ 1037 function To_Object (Value : in Duration) return Object is 1038 begin 1039 return Object '(Controlled with 1040 V => Object_Value '(Of_Type => TYPE_TIME, 1041 Time_Value => Value), 1042 Type_Def => Duration_Type'Access); 1043 end To_Object; 1044 1045 -- ------------------------------ 1046 -- Convert a string into a generic typed object. 1047 -- ------------------------------ 1048 function To_Object (Value : String) return Object is 1049 begin 1050 return Object '(Controlled with 1051 V => Object_Value '(Of_Type => TYPE_STRING, 1052 String_Proxy => new String_Proxy '(Ref_Counter => ONE, 1053 Len => Value'Length, 1054 Value => Value)), 1055 Type_Def => Str_Type'Access); 1056 end To_Object; 1057 1058 -- ------------------------------ 1059 -- Convert a wide string into a generic typed object. 1060 -- ------------------------------ 1061 function To_Object (Value : Wide_Wide_String) return Object is 1062 begin 1063 return Object '(Controlled with 1064 V => Object_Value '(Of_Type => TYPE_WIDE_STRING, 1065 Wide_Proxy => new Wide_String_Proxy 1066 '(Ref_Counter => ONE, 1067 Len => Value'Length, 1068 Value => Value)), 1069 Type_Def => WString_Type'Access); 1070 end To_Object; 1071 1072 -- ------------------------------ 1073 -- Convert an unbounded string into a generic typed object. 1074 -- ------------------------------ 1075 function To_Object (Value : Unbounded_String) return Object is 1076 Len : constant Natural := Length (Value); 1077 begin 1078 return Object '(Controlled with 1079 V => Object_Value '(Of_Type => TYPE_STRING, 1080 String_Proxy => new String_Proxy 1081 '(Ref_Counter => ONE, 1082 Len => Len, 1083 Value => To_String (Value))), 1084 Type_Def => Str_Type'Access); 1085 end To_Object; 1086 1087 -- ------------------------------ 1088 -- Convert a unbounded wide string into a generic typed object. 1089 -- ------------------------------ 1090 function To_Object (Value : Unbounded_Wide_Wide_String) return Object is 1091 Len : constant Natural := Length (Value); 1092 begin 1093 return Object '(Controlled with 1094 V => Object_Value '(Of_Type => TYPE_WIDE_STRING, 1095 Wide_Proxy => new Wide_String_Proxy 1096 '(Ref_Counter => ONE, 1097 Len => Len, 1098 Value => To_Wide_Wide_String (Value))), 1099 Type_Def => WString_Type'Access); 1100 end To_Object; 1101 1102 function To_Object (Value : access Util.Beans.Basic.Readonly_Bean'Class; 1103 Storage : in Storage_Type := DYNAMIC) return Object is 1104 begin 1105 if Value = null then 1106 return Object '(Controlled with 1107 V => Object_Value '(Of_Type => TYPE_BEAN, 1108 Proxy => null), 1109 Type_Def => Bn_Type'Access); 1110 else 1111 return Object '(Controlled with 1112 V => Object_Value '(Of_Type => TYPE_BEAN, 1113 Proxy => new Bean_Proxy '(Ref_Counter => ONE, 1114 Bean => Value, 1115 Storage => Storage)), 1116 Type_Def => Bn_Type'Access); 1117 end if; 1118 end To_Object; 1119 1120 -- ------------------------------ 1121 -- Convert the object to an object of another time. 1122 -- Force the object to be an integer. 1123 -- ------------------------------ 1124 function Cast_Integer (Value : Object) return Object is 1125 begin 1126 return Object '(Controlled with 1127 V => Object_Value '(Of_Type => TYPE_INTEGER, 1128 Int_Value => Value.Type_Def.To_Long_Long (Value.V)), 1129 Type_Def => Integer_Type'Access); 1130 end Cast_Integer; 1131 1132 -- ------------------------------ 1133 -- Force the object to be a float. 1134 -- ------------------------------ 1135 function Cast_Float (Value : Object) return Object is 1136 begin 1137 return Object '(Controlled with 1138 V => Object_Value '(Of_Type => TYPE_FLOAT, 1139 Float_Value => Value.Type_Def.To_Long_Float (Value.V)), 1140 Type_Def => Flt_Type'Access); 1141 end Cast_Float; 1142 1143 -- ------------------------------ 1144 -- Convert the object to an object of another time. 1145 -- Force the object to be a duration. 1146 -- ------------------------------ 1147 function Cast_Duration (Value : Object) return Object is 1148 begin 1149 return Object '(Controlled with 1150 V => Object_Value '(Of_Type => TYPE_TIME, 1151 Time_Value => Value.Type_Def.To_Duration (Value.V)), 1152 Type_Def => Duration_Type'Access); 1153 end Cast_Duration; 1154 1155 -- ------------------------------ 1156 -- Force the object to be a string. 1157 -- ------------------------------ 1158 function Cast_String (Value : Object) return Object is 1159 begin 1160 if Value.V.Of_Type = TYPE_STRING or Value.V.Of_Type = TYPE_WIDE_STRING then 1161 return Value; 1162 else 1163 return To_Object (To_Wide_Wide_String (Value)); 1164 end if; 1165 end Cast_String; 1166 1167 -- ------------------------------ 1168 -- Find the best type to be used to compare two operands. 1169 -- 1170 -- ------------------------------ 1171 function Get_Compare_Type (Left, Right : Object) return Data_Type is 1172 begin 1173 -- Operands are of the same type. 1174 if Left.V.Of_Type = Right.V.Of_Type then 1175 return Left.V.Of_Type; 1176 end if; 1177 1178 -- 12 >= "23" 1179 -- if Left.Of_Type = TYPE_STRING or 1180 case Left.V.Of_Type is 1181 when TYPE_BOOLEAN => 1182 case Right.V.Of_Type is 1183 when TYPE_INTEGER | TYPE_BOOLEAN | TYPE_TIME => 1184 return TYPE_INTEGER; 1185 1186 when TYPE_FLOAT | TYPE_STRING | TYPE_WIDE_STRING => 1187 return Right.V.Of_Type; 1188 1189 when others => 1190 null; 1191 end case; 1192 1193 when TYPE_INTEGER => 1194 case Right.V.Of_Type is 1195 when TYPE_BOOLEAN | TYPE_TIME => 1196 return TYPE_INTEGER; 1197 1198 when TYPE_FLOAT => 1199 return TYPE_FLOAT; 1200 1201 when others => 1202 null; 1203 end case; 1204 1205 when TYPE_TIME => 1206 case Right.V.Of_Type is 1207 when TYPE_INTEGER | TYPE_BOOLEAN | TYPE_FLOAT => 1208 return TYPE_INTEGER; 1209 1210 when others => 1211 null; 1212 1213 end case; 1214 1215 when TYPE_FLOAT => 1216 case Right.V.Of_Type is 1217 when TYPE_INTEGER | TYPE_BOOLEAN => 1218 return TYPE_FLOAT; 1219 1220 when TYPE_TIME => 1221 return TYPE_INTEGER; 1222 1223 when others => 1224 null; 1225 end case; 1226 1227 when others => 1228 null; 1229 end case; 1230 return TYPE_STRING; 1231 end Get_Compare_Type; 1232 1233 -- ------------------------------ 1234 -- Find the data type to be used for an arithmetic operation between two objects. 1235 -- ------------------------------ 1236 function Get_Arithmetic_Type (Left, Right : Object) return Data_Type is 1237 begin 1238 if Left.V.Of_Type = TYPE_FLOAT or Right.V.Of_Type = TYPE_FLOAT then 1239 return TYPE_FLOAT; 1240 end if; 1241 if Left.V.Of_Type = TYPE_INTEGER or Right.V.Of_Type = TYPE_INTEGER then 1242 return TYPE_INTEGER; 1243 end if; 1244 if Left.V.Of_Type = TYPE_BOOLEAN and Right.V.Of_Type = TYPE_BOOLEAN then 1245 return TYPE_BOOLEAN; 1246 end if; 1247 return TYPE_FLOAT; 1248 end Get_Arithmetic_Type; 1249 1250 -- ------------------------------ 1251 -- Find the data type to be used for a composition operation between two objects. 1252 -- ------------------------------ 1253 function Get_Compose_Type (Left, Right : Object) return Data_Type is 1254 begin 1255 if Left.V.Of_Type = Right.V.Of_Type then 1256 return Left.V.Of_Type; 1257 end if; 1258 if Left.V.Of_Type = TYPE_FLOAT or Right.V.Of_Type = TYPE_FLOAT then 1259 return TYPE_FLOAT; 1260 end if; 1261 if Left.V.Of_Type = TYPE_INTEGER or Right.V.Of_Type = TYPE_INTEGER then 1262 return TYPE_INTEGER; 1263 end if; 1264 if Left.V.Of_Type = TYPE_TIME or Right.V.Of_Type = TYPE_TIME then 1265 return TYPE_TIME; 1266 end if; 1267 if Left.V.Of_Type = TYPE_BOOLEAN and Right.V.Of_Type = TYPE_BOOLEAN then 1268 return TYPE_BOOLEAN; 1269 end if; 1270 return TYPE_FLOAT; 1271 end Get_Compose_Type; 1272 1273 -- ------------------------------ 1274 -- Comparison of objects 1275 -- ------------------------------ 1276 generic 1277 with function Int_Comparator (Left, Right : Long_Long_Integer) return Boolean; 1278 with function Time_Comparator (Left, Right : Duration) return Boolean; 1279 with function Boolean_Comparator (Left, Right : Boolean) return Boolean; 1280 with function Float_Comparator (Left, Right : Long_Long_Float) return Boolean; 1281 with function String_Comparator (Left, Right : String) return Boolean; 1282 with function Wide_String_Comparator (Left, Right : Wide_Wide_String) 1283 return Boolean; 1284 function Compare (Left, Right : Object) return Boolean; 1285 1286 -- ------------------------------ 1287 -- Comparison of objects 1288 -- ------------------------------ 1289 function Compare (Left, Right : Object) return Boolean is 1290 T : constant Data_Type := Get_Compare_Type (Left, Right); 1291 begin 1292 case T is 1293 when TYPE_BOOLEAN => 1294 return Boolean_Comparator (Left.Type_Def.To_Boolean (Left.V), 1295 Right.Type_Def.To_Boolean (Right.V)); 1296 1297 when TYPE_INTEGER => 1298 return Int_Comparator (Left.Type_Def.To_Long_Long (Left.V), 1299 Right.Type_Def.To_Long_Long (Right.V)); 1300 1301 when TYPE_TIME => 1302 return Time_Comparator (Left.Type_Def.To_Duration (Left.V), 1303 Right.Type_Def.To_Duration (Right.V)); 1304 1305 when TYPE_FLOAT => 1306 return Float_Comparator (Left.Type_Def.To_Long_Float (Left.V), 1307 Right.Type_Def.To_Long_Float (Right.V)); 1308 1309 when TYPE_STRING => 1310 return String_Comparator (To_String (Left), To_String (Right)); 1311 1312 when TYPE_WIDE_STRING => 1313 return Wide_String_Comparator (To_Wide_Wide_String (Left), 1314 To_Wide_Wide_String (Right)); 1315 1316 when others => 1317 return False; 1318 end case; 1319 end Compare; 1320 1321 function ">" (Left, Right : Object) return Boolean is 1322 function Cmp is new Compare (Int_Comparator => ">", 1323 Time_Comparator => ">", 1324 Boolean_Comparator => ">", 1325 Float_Comparator => ">", 1326 String_Comparator => ">", 1327 Wide_String_Comparator => ">"); 1328 begin 1329 return Cmp (Left, Right); 1330 end ">"; 1331 1332 function "<" (Left, Right : Object) return Boolean is 1333 function Cmp is new Compare (Int_Comparator => "<", 1334 Time_Comparator => "<", 1335 Boolean_Comparator => "<", 1336 Float_Comparator => "<", 1337 String_Comparator => "<", 1338 Wide_String_Comparator => "<"); 1339 begin 1340 return Cmp (Left, Right); 1341 end "<"; 1342 1343 function "<=" (Left, Right : Object) return Boolean is 1344 function Cmp is new Compare (Int_Comparator => "<=", 1345 Time_Comparator => "<=", 1346 Boolean_Comparator => "<=", 1347 Float_Comparator => "<=", 1348 String_Comparator => "<=", 1349 Wide_String_Comparator => "<="); 1350 begin 1351 return Cmp (Left, Right); 1352 end "<="; 1353 1354 function ">=" (Left, Right : Object) return Boolean is 1355 function Cmp is new Compare (Int_Comparator => ">=", 1356 Time_Comparator => ">=", 1357 Boolean_Comparator => ">=", 1358 Float_Comparator => ">=", 1359 String_Comparator => ">=", 1360 Wide_String_Comparator => ">="); 1361 begin 1362 return Cmp (Left, Right); 1363 end ">="; 1364-- function "=" (Left, Right : Object) return Boolean; 1365 1366 function "=" (Left, Right : Object) return Boolean is 1367 function Cmp is new Compare (Int_Comparator => "=", 1368 Time_Comparator => "=", 1369 Boolean_Comparator => "=", 1370 Float_Comparator => "=", 1371 String_Comparator => "=", 1372 Wide_String_Comparator => "="); 1373 begin 1374 return Cmp (Left, Right); 1375 end "="; 1376 1377 -- ------------------------------ 1378 -- Arithmetic operations of objects 1379 -- ------------------------------ 1380 generic 1381 with function Int_Operation (Left, Right : Long_Long_Integer) 1382 return Long_Long_Integer; 1383 with function Duration_Operation (Left, Right : Duration) 1384 return Duration; 1385 with function Float_Operation (Left, Right : Long_Long_Float) 1386 return Long_Long_Float; 1387 function Arith (Left, Right : Object) return Object; 1388 1389 -- Comparison of objects 1390 function Arith (Left, Right : Object) return Object is 1391 begin 1392 -- If we have a time object, keep the time definition. 1393 if Left.V.Of_Type = TYPE_TIME then 1394 return Result : Object do 1395 Result.Type_Def := Left.Type_Def; 1396 Result.V := Object_Value 1397 '(Of_Type => TYPE_TIME, 1398 Time_Value => Duration_Operation 1399 (Left.Type_Def.To_Duration (Left.V), 1400 Right.Type_Def.To_Duration (Right.V))); 1401 end return; 1402 end if; 1403 if Right.V.Of_Type = TYPE_TIME then 1404 return Result : Object do 1405 Result.Type_Def := Right.Type_Def; 1406 Result.V := Object_Value 1407 '(Of_Type => TYPE_TIME, 1408 Time_Value => Duration_Operation (Left.Type_Def.To_Duration (Left.V), 1409 Right.Type_Def.To_Duration (Right.V))); 1410 end return; 1411 end if; 1412 declare 1413 T : constant Data_Type := Get_Arithmetic_Type (Left, Right); 1414 begin 1415 case T is 1416 when TYPE_INTEGER => 1417 return To_Object (Int_Operation (Left.Type_Def.To_Long_Long (Left.V), 1418 Right.Type_Def.To_Long_Long (Right.V))); 1419 1420 when TYPE_FLOAT => 1421 return To_Object (Float_Operation (Left.Type_Def.To_Long_Float (Left.V), 1422 Right.Type_Def.To_Long_Float (Right.V))); 1423 1424 when others => 1425 return Left; 1426 end case; 1427 end; 1428 end Arith; 1429 1430 -- Arithmetic operations on objects 1431 function "+" (Left, Right : Object) return Object is 1432 function Operation is new Arith (Int_Operation => "+", 1433 Duration_Operation => "+", 1434 Float_Operation => "+"); 1435 begin 1436 return Operation (Left, Right); 1437 end "+"; 1438 1439 function "-" (Left, Right : Object) return Object is 1440 function Operation is new Arith (Int_Operation => "-", 1441 Duration_Operation => "-", 1442 Float_Operation => "-"); 1443 begin 1444 return Operation (Left, Right); 1445 end "-"; 1446 1447 function "-" (Left : Object) return Object is 1448 begin 1449 case Left.V.Of_Type is 1450 when TYPE_INTEGER => 1451 return To_Object (-Left.Type_Def.To_Long_Long (Left.V)); 1452 1453 when TYPE_TIME => 1454 return To_Object (-Left.Type_Def.To_Duration (Left.V)); 1455 1456 when TYPE_FLOAT => 1457 return To_Object (-(Left.Type_Def.To_Long_Float (Left.V))); 1458 1459 when others => 1460 return Left; 1461 1462 end case; 1463 end "-"; 1464 1465 function "*" (Left, Right : Object) return Object is 1466 function Operation is new Arith (Int_Operation => "*", 1467 Duration_Operation => "+", 1468 Float_Operation => "*"); 1469 begin 1470 return Operation (Left, Right); 1471 end "*"; 1472 1473 function "/" (Left, Right : Object) return Object is 1474 function Operation is new Arith (Int_Operation => "/", 1475 Duration_Operation => "-", 1476 Float_Operation => "/"); 1477 begin 1478 return Operation (Left, Right); 1479 end "/"; 1480 1481 function "mod" (Left, Right : Object) return Object is 1482 function "mod" (Left, Right : Long_Long_Float) return Long_Long_Float; 1483 1484 function "mod" (Left, Right : Long_Long_Float) return Long_Long_Float is 1485 L : constant Long_Long_Integer := Long_Long_Integer (Left); 1486 R : constant Long_Long_Integer := Long_Long_Integer (Right); 1487 begin 1488 return Long_Long_Float (L mod R); 1489 end "mod"; 1490 1491 function Operation is new Arith (Int_Operation => "mod", 1492 Duration_Operation => "-", 1493 Float_Operation => "mod"); 1494 begin 1495 return Operation (Left, Right); 1496 end "mod"; 1497 1498 function "&" (Left, Right : Object) return Object is 1499 T : constant Data_Type := Get_Compose_Type (Left, Right); 1500 begin 1501 case T is 1502 when TYPE_BOOLEAN => 1503 return To_Object (To_Boolean (Left) and To_Boolean (Right)); 1504 1505 when others => 1506 return To_Object (To_String (Left) & To_String (Right)); 1507 1508 end case; 1509 end "&"; 1510 1511 overriding 1512 procedure Adjust (Obj : in out Object) is 1513 begin 1514 case Obj.V.Of_Type is 1515 when TYPE_BEAN => 1516 if Obj.V.Proxy /= null then 1517 Util.Concurrent.Counters.Increment (Obj.V.Proxy.Ref_Counter); 1518 end if; 1519 1520 when TYPE_STRING => 1521 if Obj.V.String_Proxy /= null then 1522 Util.Concurrent.Counters.Increment (Obj.V.String_Proxy.Ref_Counter); 1523 end if; 1524 1525 when TYPE_WIDE_STRING => 1526 if Obj.V.Wide_Proxy /= null then 1527 Util.Concurrent.Counters.Increment (Obj.V.Wide_Proxy.Ref_Counter); 1528 end if; 1529 1530 when others => 1531 null; 1532 1533 end case; 1534 end Adjust; 1535 1536 procedure Free is 1537 new Ada.Unchecked_Deallocation (Object => Basic.Readonly_Bean'Class, 1538 Name => Basic.Readonly_Bean_Access); 1539 1540 procedure Free is 1541 new Ada.Unchecked_Deallocation (Object => Proxy'Class, 1542 Name => Bean_Proxy_Access); 1543 1544 procedure Free is 1545 new Ada.Unchecked_Deallocation (Object => String_Proxy, 1546 Name => String_Proxy_Access); 1547 1548 procedure Free is 1549 new Ada.Unchecked_Deallocation (Object => Wide_String_Proxy, 1550 Name => Wide_String_Proxy_Access); 1551 1552 overriding 1553 procedure Finalize (Obj : in out Object) is 1554 Release : Boolean; 1555 begin 1556 case Obj.V.Of_Type is 1557 when TYPE_STRING => 1558 if Obj.V.String_Proxy /= null then 1559 Util.Concurrent.Counters.Decrement (Obj.V.String_Proxy.Ref_Counter, Release); 1560 if Release then 1561 Free (Obj.V.String_Proxy); 1562 else 1563 Obj.V.String_Proxy := null; 1564 end if; 1565 end if; 1566 1567 when TYPE_WIDE_STRING => 1568 if Obj.V.Wide_Proxy /= null then 1569 Util.Concurrent.Counters.Decrement (Obj.V.Wide_Proxy.Ref_Counter, Release); 1570 if Release then 1571 Free (Obj.V.Wide_Proxy); 1572 else 1573 Obj.V.Wide_Proxy := null; 1574 end if; 1575 end if; 1576 1577 when TYPE_BEAN => 1578 if Obj.V.Proxy /= null then 1579 Util.Concurrent.Counters.Decrement (Obj.V.Proxy.Ref_Counter, Release); 1580 if Release then 1581 Obj.V.Proxy.all.Release; 1582 Free (Obj.V.Proxy); 1583 else 1584 Obj.V.Proxy := null; 1585 end if; 1586 end if; 1587 1588 when others => 1589 null; 1590 1591 end case; 1592 end Finalize; 1593 1594 -- ------------------------------ 1595 -- Release the object pointed to by the proxy (if necessary). 1596 -- ------------------------------ 1597 overriding 1598 procedure Release (P : in out Bean_Proxy) is 1599 begin 1600 if P.Storage = DYNAMIC and P.Bean /= null then 1601 declare 1602 Bean : Basic.Readonly_Bean_Access := P.Bean.all'Access; 1603 begin 1604 P.Bean := null; 1605 Free (Bean); 1606 end; 1607 end if; 1608 end Release; 1609 1610end Util.Beans.Objects; 1611