1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME COMPONENTS -- 4-- -- 5-- S Y S T E M . V A X _ F L O A T _ O P E R A T I O N S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1997-2012, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. -- 17-- -- 18-- As a special exception under Section 7 of GPL version 3, you are granted -- 19-- additional permissions described in the GCC Runtime Library Exception, -- 20-- version 3.1, as published by the Free Software Foundation. -- 21-- -- 22-- You should have received a copy of the GNU General Public License and -- 23-- a copy of the GCC Runtime Library Exception along with this program; -- 24-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25-- <http://www.gnu.org/licenses/>. -- 26-- -- 27-- GNAT was originally developed by the GNAT team at New York University. -- 28-- Extensive contributions were provided by Ada Core Technologies Inc. -- 29-- -- 30------------------------------------------------------------------------------ 31 32-- This is a dummy body for use on non-Alpha systems so that the library 33-- can compile. This dummy version uses ordinary conversions and other 34-- arithmetic operations. It is used only for testing purposes in the 35-- case where the -gnatdm switch is used to force testing of VMS features 36-- on non-VMS systems. 37 38with System.IO; 39 40package body System.Vax_Float_Operations is 41 pragma Warnings (Off); 42 -- Warnings about infinite recursion when the -gnatdm switch is used 43 44 ----------- 45 -- Abs_F -- 46 ----------- 47 48 function Abs_F (X : F) return F is 49 begin 50 return abs X; 51 end Abs_F; 52 53 ----------- 54 -- Abs_G -- 55 ----------- 56 57 function Abs_G (X : G) return G is 58 begin 59 return abs X; 60 end Abs_G; 61 62 ----------- 63 -- Add_F -- 64 ----------- 65 66 function Add_F (X, Y : F) return F is 67 begin 68 return X + Y; 69 end Add_F; 70 71 ----------- 72 -- Add_G -- 73 ----------- 74 75 function Add_G (X, Y : G) return G is 76 begin 77 return X + Y; 78 end Add_G; 79 80 ------------ 81 -- D_To_G -- 82 ------------ 83 84 function D_To_G (X : D) return G is 85 begin 86 return G (X); 87 end D_To_G; 88 89 -------------------- 90 -- Debug_Output_D -- 91 -------------------- 92 93 procedure Debug_Output_D (Arg : D) is 94 begin 95 System.IO.Put (D'Image (Arg)); 96 end Debug_Output_D; 97 98 -------------------- 99 -- Debug_Output_F -- 100 -------------------- 101 102 procedure Debug_Output_F (Arg : F) is 103 begin 104 System.IO.Put (F'Image (Arg)); 105 end Debug_Output_F; 106 107 -------------------- 108 -- Debug_Output_G -- 109 -------------------- 110 111 procedure Debug_Output_G (Arg : G) is 112 begin 113 System.IO.Put (G'Image (Arg)); 114 end Debug_Output_G; 115 116 -------------------- 117 -- Debug_String_D -- 118 -------------------- 119 120 Debug_String_Buffer : String (1 .. 32); 121 -- Buffer used by all Debug_String_x routines for returning result 122 123 function Debug_String_D (Arg : D) return System.Address is 124 Image_String : constant String := D'Image (Arg) & ASCII.NUL; 125 Image_Size : constant Integer := Image_String'Length; 126 127 begin 128 Debug_String_Buffer (1 .. Image_Size) := Image_String; 129 return Debug_String_Buffer (1)'Address; 130 end Debug_String_D; 131 132 -------------------- 133 -- Debug_String_F -- 134 -------------------- 135 136 function Debug_String_F (Arg : F) return System.Address is 137 Image_String : constant String := F'Image (Arg) & ASCII.NUL; 138 Image_Size : constant Integer := Image_String'Length; 139 140 begin 141 Debug_String_Buffer (1 .. Image_Size) := Image_String; 142 return Debug_String_Buffer (1)'Address; 143 end Debug_String_F; 144 145 -------------------- 146 -- Debug_String_G -- 147 -------------------- 148 149 function Debug_String_G (Arg : G) return System.Address is 150 Image_String : constant String := G'Image (Arg) & ASCII.NUL; 151 Image_Size : constant Integer := Image_String'Length; 152 153 begin 154 Debug_String_Buffer (1 .. Image_Size) := Image_String; 155 return Debug_String_Buffer (1)'Address; 156 end Debug_String_G; 157 158 ----------- 159 -- Div_F -- 160 ----------- 161 162 function Div_F (X, Y : F) return F is 163 begin 164 return X / Y; 165 end Div_F; 166 167 ----------- 168 -- Div_G -- 169 ----------- 170 171 function Div_G (X, Y : G) return G is 172 begin 173 return X / Y; 174 end Div_G; 175 176 ---------- 177 -- Eq_F -- 178 ---------- 179 180 function Eq_F (X, Y : F) return Boolean is 181 begin 182 return X = Y; 183 end Eq_F; 184 185 ---------- 186 -- Eq_G -- 187 ---------- 188 189 function Eq_G (X, Y : G) return Boolean is 190 begin 191 return X = Y; 192 end Eq_G; 193 194 ------------ 195 -- F_To_G -- 196 ------------ 197 198 function F_To_G (X : F) return G is 199 begin 200 return G (X); 201 end F_To_G; 202 203 ------------ 204 -- F_To_Q -- 205 ------------ 206 207 function F_To_Q (X : F) return Q is 208 begin 209 return Q (X); 210 end F_To_Q; 211 212 ------------ 213 -- F_To_S -- 214 ------------ 215 216 function F_To_S (X : F) return S is 217 begin 218 return S (X); 219 end F_To_S; 220 221 ------------ 222 -- G_To_D -- 223 ------------ 224 225 function G_To_D (X : G) return D is 226 begin 227 return D (X); 228 end G_To_D; 229 230 ------------ 231 -- G_To_F -- 232 ------------ 233 234 function G_To_F (X : G) return F is 235 begin 236 return F (X); 237 end G_To_F; 238 239 ------------ 240 -- G_To_Q -- 241 ------------ 242 243 function G_To_Q (X : G) return Q is 244 begin 245 return Q (X); 246 end G_To_Q; 247 248 ------------ 249 -- G_To_T -- 250 ------------ 251 252 function G_To_T (X : G) return T is 253 begin 254 return T (X); 255 end G_To_T; 256 257 ---------- 258 -- Le_F -- 259 ---------- 260 261 function Le_F (X, Y : F) return Boolean is 262 begin 263 return X <= Y; 264 end Le_F; 265 266 ---------- 267 -- Le_G -- 268 ---------- 269 270 function Le_G (X, Y : G) return Boolean is 271 begin 272 return X <= Y; 273 end Le_G; 274 275 ---------- 276 -- Lt_F -- 277 ---------- 278 279 function Lt_F (X, Y : F) return Boolean is 280 begin 281 return X < Y; 282 end Lt_F; 283 284 ---------- 285 -- Lt_G -- 286 ---------- 287 288 function Lt_G (X, Y : G) return Boolean is 289 begin 290 return X < Y; 291 end Lt_G; 292 293 ----------- 294 -- Mul_F -- 295 ----------- 296 297 function Mul_F (X, Y : F) return F is 298 begin 299 return X * Y; 300 end Mul_F; 301 302 ----------- 303 -- Mul_G -- 304 ----------- 305 306 function Mul_G (X, Y : G) return G is 307 begin 308 return X * Y; 309 end Mul_G; 310 311 ---------- 312 -- Ne_F -- 313 ---------- 314 315 function Ne_F (X, Y : F) return Boolean is 316 begin 317 return X /= Y; 318 end Ne_F; 319 320 ---------- 321 -- Ne_G -- 322 ---------- 323 324 function Ne_G (X, Y : G) return Boolean is 325 begin 326 return X /= Y; 327 end Ne_G; 328 329 ----------- 330 -- Neg_F -- 331 ----------- 332 333 function Neg_F (X : F) return F is 334 begin 335 return -X; 336 end Neg_F; 337 338 ----------- 339 -- Neg_G -- 340 ----------- 341 342 function Neg_G (X : G) return G is 343 begin 344 return -X; 345 end Neg_G; 346 347 -------- 348 -- pd -- 349 -------- 350 351 procedure pd (Arg : D) is 352 begin 353 System.IO.Put_Line (D'Image (Arg)); 354 end pd; 355 356 -------- 357 -- pf -- 358 -------- 359 360 procedure pf (Arg : F) is 361 begin 362 System.IO.Put_Line (F'Image (Arg)); 363 end pf; 364 365 -------- 366 -- pg -- 367 -------- 368 369 procedure pg (Arg : G) is 370 begin 371 System.IO.Put_Line (G'Image (Arg)); 372 end pg; 373 374 ------------ 375 -- Q_To_F -- 376 ------------ 377 378 function Q_To_F (X : Q) return F is 379 begin 380 return F (X); 381 end Q_To_F; 382 383 ------------ 384 -- Q_To_G -- 385 ------------ 386 387 function Q_To_G (X : Q) return G is 388 begin 389 return G (X); 390 end Q_To_G; 391 392 ------------ 393 -- S_To_F -- 394 ------------ 395 396 function S_To_F (X : S) return F is 397 begin 398 return F (X); 399 end S_To_F; 400 401 -------------- 402 -- Return_D -- 403 -------------- 404 405 function Return_D (X : D) return D is 406 begin 407 return X; 408 end Return_D; 409 410 -------------- 411 -- Return_F -- 412 -------------- 413 414 function Return_F (X : F) return F is 415 begin 416 return X; 417 end Return_F; 418 419 -------------- 420 -- Return_G -- 421 -------------- 422 423 function Return_G (X : G) return G is 424 begin 425 return X; 426 end Return_G; 427 428 ----------- 429 -- Sub_F -- 430 ----------- 431 432 function Sub_F (X, Y : F) return F is 433 begin 434 return X - Y; 435 end Sub_F; 436 437 ----------- 438 -- Sub_G -- 439 ----------- 440 441 function Sub_G (X, Y : G) return G is 442 begin 443 return X - Y; 444 end Sub_G; 445 446 ------------ 447 -- T_To_D -- 448 ------------ 449 450 function T_To_D (X : T) return D is 451 begin 452 return G_To_D (T_To_G (X)); 453 end T_To_D; 454 455 ------------ 456 -- T_To_G -- 457 ------------ 458 459 function T_To_G (X : T) return G is 460 begin 461 return G (X); 462 end T_To_G; 463 464 ------------- 465 -- Valid_D -- 466 ------------- 467 468 -- For now, convert to IEEE and do Valid test on result. This is not quite 469 -- accurate, but is good enough in practice. 470 471 function Valid_D (Arg : D) return Boolean is 472 Val : constant T := G_To_T (D_To_G (Arg)); 473 begin 474 return Val'Valid; 475 end Valid_D; 476 477 ------------- 478 -- Valid_F -- 479 ------------- 480 481 -- For now, convert to IEEE and do Valid test on result. This is not quite 482 -- accurate, but is good enough in practice. 483 484 function Valid_F (Arg : F) return Boolean is 485 Val : constant S := F_To_S (Arg); 486 begin 487 return Val'Valid; 488 end Valid_F; 489 490 ------------- 491 -- Valid_G -- 492 ------------- 493 494 -- For now, convert to IEEE and do Valid test on result. This is not quite 495 -- accurate, but is good enough in practice. 496 497 function Valid_G (Arg : G) return Boolean is 498 Val : constant T := G_To_T (Arg); 499 begin 500 return Val'Valid; 501 end Valid_G; 502 503end System.Vax_Float_Operations; 504