/pliant/language/type/number/float.pli
 
 1  # Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx 
 2  # 
 3  # This program is free software; you can redistribute it and/or 
 4  # modify it under the terms of the GNU General Public License version 2 
 5  # as published by the Free Software Foundation. 
 6  # 
 7  # This program is distributed in the hope that it will be useful, 
 8  # but WITHOUT ANY WARRANTY; without even the implied warranty of 
 9  # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the 
 10  # GNU General Public License for more details. 
 11  # 
 12  # You should have received a copy of the GNU General Public License 
 13  # version 2 along with this program; if not, write to the Free Software 
 14  # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA. 
 15   
 16  scope "/pliant/language/" "/pliant/install/" 
 17  module "/pliant/install/ring2.pli" 
 18   
 19  constant do_init true 
 20  constant buggy_pow true 
 21   
 22   
 23  type Float 
 24    field Int low high 
 25   
 26  alias Float64 Float 
 27   
 28   
 29  type Float32 
 30    field Int value 
 31  (addressof:Float32 map Type) flags := Float32:flags .and. .not. type_flag_atomic 
 32   
 33   
 34  if do_init 
 35    function i386_finit 
 36      void 
 37    function generate_i386_finit i f 
 38      arg_rw Instruction i ; arg_rw Function f 
 39      code_immediat 11011011b 1 ; code_immediat 11100011b 1 
 40    (the_function i386_finit) set_generate_binary (the_function generate_i386_finit Instruction Function) 
 41   
 42   
 43  function i386_wait 
 44    void 
 45  function generate_i386_wait i f 
 46    arg_rw Instruction i ; arg_rw Function f 
 47    code_immediat 10011011b 1 
 48  (the_function i386_wait) set_generate_binary (the_function generate_i386_wait Instruction Function) 
 49   
 50   
 51  function i386_fld f 
 52    arg Float f 
 53  function generate_i386_fld64 i f 
 54    arg_rw Instruction i ; arg_rw Function f 
 55    i386_regmem 11011101b 1 000b i:0 
 56  (the_function i386_fld Float) set_generate_binary (the_function generate_i386_fld64 Instruction Function) 
 57   
 58  function i386_fld f 
 59    arg Float32 f 
 60  function generate_i386_fld32 i f 
 61    arg_rw Instruction i ; arg_rw Function f 
 62    i386_regmem 11011001b 1 000b i:0 
 63  (the_function i386_fld Float32) set_generate_binary (the_function generate_i386_fld32 Instruction Function) 
 64   
 65   
 66  function i386_fstp f 
 67    arg_w Float f 
 68  function generate_i386_fstp64 i f 
 69    arg_rw Instruction i ; arg_rw Function f 
 70    i386_regmem 11011101b 1 011b i:0 
 71  (the_function i386_fstp Float) set_generate_binary (the_function generate_i386_fstp64 Instruction Function) 
 72   
 73  function i386_fstp f 
 74    arg_w Float32 f 
 75  function generate_i386_fstp32 i f 
 76    arg_rw Instruction i ; arg_rw Function f 
 77    i386_regmem 11011001b 1 011b i:0 
 78  (the_function i386_fstp Float32) set_generate_binary (the_function generate_i386_fstp32 Instruction Function) 
 79   
 80   
 81  function i386_fincstp 
 82    void 
 83  function generate_i386_fincstp i f 
 84    arg_rw Instruction i ; arg_rw Function f 
 85    code_immediat 0D9h 1 ; code_immediat 0F7h 1  
 86  (the_function i386_fincstp) set_generate_binary (the_function generate_i386_fincstp Instruction Function) 
 87   
 88   
 89  function i386_faddp 
 90    void 
 91  function generate_i386_faddp i f 
 92    arg_rw Instruction i ; arg_rw Function f 
 93    code_immediat 11011110b 1 ; code_immediat 11000000b+1 1 
 94  the_function:i386_faddp set_generate_binary (the_function generate_i386_faddp Instruction Function) 
 95   
 96  function i386_fadd f 
 97    arg Float f 
 98  function generate_i386_fadd i f 
 99    arg_rw Instruction i ; arg_rw Function f 
 100    i386_regmem 11011100b 1 000b i:0 
 101  (the_function i386_fadd Float) set_generate_binary (the_function generate_i386_fadd Instruction Function) 
 102   
 103  function '+' a b -> r 
 104    arg Float r 
 105    gcc_inline "*(double *)@3 = *(double *)@1 + *(double *)@2;" 
 106  function assemble_plus_Float i gc 
 107    arg_rw Instruction i ; arg_rw GeneratorContext gc 
 108    var Pointer:Instruction cur :> i 
 109    cur :> gc insert_after_instruction cur (instruction (the_function i386_fld Float) i:0) 
 110    cur :> gc insert_after_instruction cur (instruction (the_function i386_fadd Float) i:1) 
 111    cur :> gc insert_after_instruction cur (instruction (the_function i386_fstp Float) i:2) 
 112    cur :> gc insert_after_instruction cur (instruction the_function:i386_wait) 
 113    gc remove i 
 114  (the_function '+' Float Float -> Float) set_generate_assembly (the_function assemble_plus_Float Instruction GeneratorContext) 
 115   
 116   
 117  function i386_fsub f 
 118    arg Float f 
 119  function generate_i386_fsub i f 
 120    arg_rw Instruction i ; arg_rw Function f 
 121    i386_regmem 11011100b 1 100b i:0 
 122  (the_function i386_fsub Float) set_generate_binary (the_function generate_i386_fsub Instruction Function) 
 123   
 124  function '-' a b -> r 
 125    arg Float r 
 126    gcc_inline "*(double *)@3 = *(double *)@1 - *(double *)@2;" 
 127  function assemble_minus_Float i gc 
 128    arg_rw Instruction i ; arg_rw GeneratorContext gc 
 129    var Pointer:Instruction cur :> i 
 130    cur :> gc insert_after_instruction cur (instruction (the_function i386_fld Float) i:0) 
 131    cur :> gc insert_after_instruction cur (instruction (the_function i386_fsub Float) i:1) 
 132    cur :> gc insert_after_instruction cur (instruction (the_function i386_fstp Float) i:2) 
 133    cur :> gc insert_after_instruction cur (instruction the_function:i386_wait) 
 134    gc remove i 
 135  (the_function '-' Float Float -> Float) set_generate_assembly (the_function assemble_minus_Float Instruction GeneratorContext) 
 136   
 137   
 138  function i386_fmul f 
 139    arg Float f 
 140  function generate_i386_fmul i f 
 141    arg_rw Instruction i ; arg_rw Function f 
 142    i386_regmem 11011100b 1 001b i:0 
 143  (the_function i386_fmul Float) set_generate_binary (the_function generate_i386_fmul Instruction Function) 
 144   
 145  function '*' a b -> r 
 146    arg Float r 
 147    gcc_inline "*(double *)@3 = *(double *)@1 * *(double *)@2;" 
 148  function assemble_multiply_Float i gc 
 149    arg_rw Instruction i ; arg_rw GeneratorContext gc 
 150    var Pointer:Instruction cur :> i 
 151    cur :> gc insert_after_instruction cur (instruction (the_function i386_fld Float) i:0) 
 152    cur :> gc insert_after_instruction cur (instruction (the_function i386_fmul Float) i:1) 
 153    cur :> gc insert_after_instruction cur (instruction (the_function i386_fstp Float) i:2) 
 154    cur :> gc insert_after_instruction cur (instruction the_function:i386_wait) 
 155    gc remove i 
 156  (the_function '*' Float Float -> Float) set_generate_assembly (the_function assemble_multiply_Float Instruction GeneratorContext) 
 157   
 158   
 159  function i386_fdiv f 
 160    arg Float f 
 161  function generate_i386_fdiv i f 
 162    arg_rw Instruction i ; arg_rw Function f 
 163    i386_regmem 11011100b 1 110b i:0 
 164  (the_function i386_fdiv Float) set_generate_binary (the_function generate_i386_fdiv Instruction Function) 
 165   
 166  function '/' a b -> r 
 167    arg Float r 
 168    gcc_inline "*(double *)@3 = *(double *)@1 / *(double *)@2;" 
 169  function assemble_divide_Float i gc 
 170    arg_rw Instruction i ; arg_rw GeneratorContext gc 
 171    var Pointer:Instruction cur :> i 
 172    cur :> gc insert_after_instruction cur (instruction (the_function i386_fld Float) i:0) 
 173    cur :> gc insert_after_instruction cur (instruction (the_function i386_fdiv Float) i:1) 
 174    cur :> gc insert_after_instruction cur (instruction (the_function i386_fstp Float) i:2) 
 175    cur :> gc insert_after_instruction cur (instruction the_function:i386_wait) 
 176    gc remove i 
 177  (the_function '/' Float Float -> Float) set_generate_assembly (the_function assemble_divide_Float Instruction GeneratorContext) 
 178   
 179   
 180  function i386_fcomp f 
 181    arg Float f 
 182  function generate_i386_fcomp i f 
 183    arg_rw Instruction i ; arg_rw Function f 
 184    i386_regmem 11011100b 1 011b i:0 
 185  (the_function i386_fcomp Float) set_generate_binary (the_function generate_i386_fcomp Instruction Function) 
 186   
 187  function i386_fstsw_ax r 
 188    arg_w Int r 
 189  function generate_i386_fstsw_ax i f 
 190    arg_rw Instruction i ; arg_rw Function f 
 191    if i:0:where=argument_register and i:0:register=i386_eax 
 192      code_immediat 11011111b 1 ; code_immediat 11100000b 1 
 193    else 
 194      error error_id_unexpected "Expected eax" 
 195  (the_function i386_fstsw_ax Int) set_generate_binary (the_function generate_i386_fstsw_ax Instruction Function) 
 196   
 197  function compare_Float a b -> c 
 198    arg Float b ; arg Int c 
 199    gcc_inline "$3 = *(double *)@1<*(double *)@2 ? "+'convert to string':compare_inferior+" : *(double *)@1>*(double *)@2 ? "+'convert to string':compare_superior+" : "+'convert to string':compare_equal+";" 
 200    gcc_inline_compare "$3 = *(double *)@1 compare *(double *)@2;" 
 201  function assemble_compare_Float i gc 
 202    arg_rw Instruction i ; arg_rw GeneratorContext gc 
 203    var Pointer:Instruction cur :> i 
 204    cur :> gc insert_after_instruction cur (instruction (the_function i386_fld Float) i:0) 
 205    cur :> gc insert_after_instruction cur (instruction (the_function i386_fcomp Float) i:1) 
 206    cur :> gc insert_after_instruction cur (instruction (the_function i386_fstsw_ax Int) (gc register i386_eax)) 
 207    cur :> gc insert_after_instruction cur (instruction (the_function i386_mov Int Int) (gc register i386_eax) i:2) 
 208    gc remove i 
 209  (the_function compare_Float Float Float -> Int) set_generate_assembly (the_function assemble_compare_Float Instruction GeneratorContext) 
 210   
 211   
 212  function i386_fcomp f32 
 213    arg Float32 f32 
 214  function generate_i386_fcomp32 i f 
 215    arg_rw Instruction i ; arg_rw Function f 
 216    i386_regmem 11011000b 1 011b i:0 
 217  (the_function i386_fcomp Float32) set_generate_binary (the_function generate_i386_fcomp32 Instruction Function) 
 218   
 219  function compare_Float32 a b -> c 
 220    arg Float32 b ; arg Int c 
 221    gcc_inline "$3 = *(float *)@1<*(float *)@2 ? "+'convert to string':compare_inferior+" : *(float *)@1>*(float *)@2 ? "+'convert to string':compare_superior+" : "+'convert to string':compare_equal+";" 
 222    gcc_inline_compare "$3 = *(float *)@1 compare *(float *)@2;" 
 223  function assemble_compare_Float32 i gc 
 224    arg_rw Instruction i ; arg_rw GeneratorContext gc 
 225    var Pointer:Instruction cur :> i 
 226    cur :> gc insert_after_instruction cur (instruction (the_function i386_fld Float32) i:0) 
 227    cur :> gc insert_after_instruction cur (instruction (the_function i386_fcomp Float32) i:1) 
 228    cur :> gc insert_after_instruction cur (instruction (the_function i386_fstsw_ax Int) (gc register i386_eax)) 
 229    cur :> gc insert_after_instruction cur (instruction (the_function i386_mov Int Int) (gc register i386_eax) i:2) 
 230    gc remove i 
 231  (the_function compare_Float32 Float32 Float32 -> Int) set_generate_assembly (the_function assemble_compare_Float32 Instruction GeneratorContext) 
 232   
 233   
 234  function i386_frndint 
 235    void 
 236  function generate_i386_frndint i f 
 237    arg_rw Instruction i ; arg_rw Function f 
 238    code_immediat 11011001b 1 ; code_immediat 11111100b 1 
 239  the_function:i386_frndint set_generate_binary (the_function generate_i386_frndint Instruction Function) 
 240   
 241  function i386_fstp i 
 242    arg Int i 
 243  function generate_i386_fstp_int i f 
 244    arg_rw Instruction i ; arg_rw Function f 
 245    i386_regmem 11011011b 1 011b i:0 
 246  (the_function i386_fstp Int) set_generate_binary (the_function generate_i386_fstp_int Instruction Function) 
 247   
 248  function 'cast Int' f -> i 
 249    arg Float f ; arg Int i 
 250    gcc_inline "$2 = (int)(*(double *)@1+0.5);" 
 251  function assemble_cast_Float_Int i gc 
 252    arg_rw Instruction i ; arg_rw GeneratorContext gc 
 253    var Pointer:Instruction cur :> i 
 254    cur :> gc insert_after_instruction cur (instruction (the_function i386_fld Float) i:0) 
 255    cur :> gc insert_after_instruction cur (instruction the_function:i386_frndint) 
 256    if i:1:where=argument_indirect 
 257      cur :> gc insert_after_instruction cur (instruction (the_function i386_fstp Int) i:1) 
 258    else 
 259      cur :> gc insert_after_instruction cur (instruction (the_function i386_add Int Int) (argument constant Int -4) (gc register i386_esp)) 
 260      cur :> gc insert_after_instruction cur (instruction (the_function i386_fstp Int) (argument indirect Int (gc register i386_esp) 0)) 
 261      cur :> gc insert_after_instruction cur (instruction (the_function i386_pop Int) i:1) 
 262    cur :> gc insert_after_instruction cur (instruction the_function:i386_wait) 
 263    gc remove i 
 264  (the_function 'cast Int' Float -> Int) set_generate_assembly (the_function assemble_cast_Float_Int Instruction GeneratorContext) 
 265   
 266   
 267  function i386_fld i 
 268    arg Int i 
 269  function generate_i386_fld_int i f 
 270    arg_rw Instruction i ; arg_rw Function f 
 271    if i:0:where=argument_constant 
 272      var Link:Int imm :> new Int ; imm := i:0:constant map Int 
 273      record_external addressof:imm false 
 274      i386_memory 11011011b 1 000b undefined undefined 1 (cast addressof:imm Int) 
 275    else 
 276      i386_regmem 11011011b 1 000b i:0 
 277  (the_function i386_fld Int) set_generate_binary (the_function generate_i386_fld_int Instruction Function) 
 278   
 279  function cast_Int_Float i -> f 
 280    arg Int i ; arg Float f 
 281    extension 
 282    gcc_inline "*(double *)@2 = $1;" 
 283  function assemble_cast_Int_Float i gc 
 284    arg_rw Instruction i ; arg_rw GeneratorContext gc 
 285    var Pointer:Instruction cur :> i 
 286    if i:0:where=argument_indirect 
 287      cur :> gc insert_after_instruction cur (instruction (the_function i386_fld Int) i:0) 
 288    else 
 289      cur :> gc insert_after_instruction cur (instruction (the_function i386_push Int) i:0) 
 290      cur :> gc insert_after_instruction cur (instruction (the_function i386_fld Int) (argument indirect Int (gc register i386_esp) 0)) 
 291      cur :> gc insert_after_instruction cur (instruction (the_function i386_add Int Int) (argument constant Int 4) (gc register i386_esp)) 
 292    check i:1:where=argument_indirect 
 293    cur :> gc insert_after_instruction cur (instruction (the_function i386_fstp Float) i:1) 
 294    cur :> gc insert_after_instruction cur (instruction the_function:i386_wait) 
 295    gc remove i 
 296  (the_function cast_Int_Float Int -> Float) set_generate_assembly (the_function assemble_cast_Int_Float Instruction GeneratorContext) 
 297   
 298  alias 'cast Float' cast_Int_Float in "/pliant/language/basic/ultrasafe.pli" 
 299   
 300   
 301  function 'cast Float' f32 -> f 
 302    arg Float32 f32 ; arg Float f 
 303    extension 
 304    gcc_inline "*(double *)@2 = *(float *)@1;" 
 305  function assemble_cast_Float32_Float i gc 
 306    arg_rw Instruction i ; arg_rw GeneratorContext gc 
 307    var Pointer:Instruction cur :> i 
 308    cur :> gc insert_after_instruction cur (instruction (the_function i386_fld Float32) i:0) 
 309    cur :> gc insert_after_instruction cur (instruction (the_function i386_fstp Float) i:1) 
 310    cur :> gc insert_after_instruction cur (instruction the_function:i386_wait) 
 311    gc remove i 
 312  (the_function 'cast Float' Float32 -> Float) set_generate_assembly (the_function assemble_cast_Float32_Float Instruction GeneratorContext) 
 313   
 314  function 'cast Float32' f -> f32 
 315    arg Float f ; arg Float32 f32 
 316    reduction 
 317    gcc_inline "*(float *)@2 = *(double *)@1;" 
 318  function assemble_cast_Float_Float32 i gc 
 319    arg_rw Instruction i ; arg_rw GeneratorContext gc 
 320    var Pointer:Instruction cur :> i 
 321    cur :> gc insert_after_instruction cur (instruction (the_function i386_fld Float) i:0) 
 322    cur :> gc insert_after_instruction cur (instruction (the_function i386_fstp Float32) i:1) 
 323    cur :> gc insert_after_instruction cur (instruction the_function:i386_wait) 
 324    gc remove i 
 325  (the_function 'cast Float32' Float -> Float32) set_generate_assembly (the_function assemble_cast_Float_Float32 Instruction GeneratorContext) 
 326   
 327   
 328  module "/pliant/language/type/misc/status.pli" 
 329   
 330  function 'cast Status' f -> s 
 331    arg Float f ; arg Status s 
 332    explicit 
 333    if (f:high .and. 7FF00000h)=7FF00000h 
 334      := undefined 
 335    else 
 336      := defined 
 337   
 338  function 'cast Float' s -> f 
 339    arg Status s ; arg Float f 
 340    extension 
 341    if s<>undefined 
 342      error error_id_unexpected "Unexpected Status value" 
 343    low := -1 ; high := -1 
 344   
 345  function 'cast Status' f32 -> s 
 346    arg Float32 f32 ; arg Status s 
 347    explicit 
 348    if (f32:value .and. 7F800000h)=7F800000h 
 349      := undefined 
 350    else 
 351      := defined 
 352   
 353  function 'cast Float32' s -> f32 
 354    arg Status s ; arg Float32 f32 
 355    extension 
 356    if s<>undefined 
 357      error error_id_unexpected "Unexpected Status value" 
 358    f32 value := -1 
 359   
 360  function i386_fabs 
 361    void 
 362  function generate_i386_fabs i f 
 363    arg_rw Instruction i ; arg_rw Function f 
 364    code_immediat 11011001b 1 ; code_immediat 11100001b 1 
 365  the_function:i386_fabs set_generate_binary (the_function generate_i386_fabs Instruction Function) 
 366   
 367  function abs f -> r 
 368    arg Float r 
 369    gcc_inline "*(double *)@2 = (*(double *)@1>=0 ? *(double *)@1 : -*(double *)@1);" 
 370  function assemble_abs_Float i gc 
 371    arg_rw Instruction i ; arg_rw GeneratorContext gc 
 372    var Pointer:Instruction cur :> i 
 373    cur :> gc insert_after_instruction cur (instruction (the_function i386_fld Float) i:0) 
 374    cur :> gc insert_after_instruction cur (instruction the_function:i386_fabs) 
 375    cur :> gc insert_after_instruction cur (instruction (the_function i386_fstp Float) i:1) 
 376    cur :> gc insert_after_instruction cur (instruction the_function:i386_wait) 
 377    gc remove i 
 378  (the_function abs Float -> Float) set_generate_assembly (the_function assemble_abs_Float Instruction GeneratorContext) 
 379   
 380   
 381  function i386_fyl2x 
 382    void 
 383  function generate_i386_fyl2x i f 
 384    arg_rw Instruction i ; arg_rw Function f 
 385    code_immediat 11011001b 1 ; code_immediat 11110001b 1 
 386  the_function:i386_fyl2x set_generate_binary (the_function generate_i386_fyl2x Instruction Function) 
 387   
 388  function i386_fldlg2 
 389    void 
 390  function generate_i386_fldlg2 i f 
 391    arg_rw Instruction i ; arg_rw Function f 
 392    code_immediat 11011001b 1 ; code_immediat 11101100b 1 
 393  the_function:i386_fldlg2 set_generate_binary (the_function generate_i386_fldlg2 Instruction Function) 
 394   
 395  function log10 f -> r 
 396    arg Float r 
 397    gcc_inline "asm( [dq]fldlg2\n[dq] [dq]fxch\n[dq] [dq]fyl2x[dq] : [dq]=t[dq] (*(double *)@2) : [dq]0[dq] (*(double *)@1));" 
 398  function assemble_log10_Float i gc 
 399    arg_rw Instruction i ; arg_rw GeneratorContext gc 
 400    var Pointer:Instruction cur :> i 
 401    cur :> gc insert_after_instruction cur (instruction the_function:i386_fldlg2) 
 402    cur :> gc insert_after_instruction cur (instruction (the_function i386_fld Float) i:0) 
 403    cur :> gc insert_after_instruction cur (instruction the_function:i386_fyl2x) 
 404    cur :> gc insert_after_instruction cur (instruction (the_function i386_fstp Float) i:1) 
 405    cur :> gc insert_after_instruction cur (instruction the_function:i386_wait) 
 406    gc remove i 
 407  (the_function log10 Float -> Float) set_generate_assembly (the_function assemble_log10_Float Instruction GeneratorContext) 
 408   
 409   
 410  function power_inline_code 
 411    void 
 412  function generate_power_inline_code i f 
 413    arg_rw Instruction i ; arg_rw Function f 
 414    code_immediat 0D9h 1 ; code_immediat 0F1h 1  # fyl2x 
 415    code_immediat 0D9h 1 ; code_immediat 0C0h 1  # fld st(0) 
 416    code_immediat 0D9h 1 ; code_immediat 0FCh 1  # frndint 
 417    code_immediat 0D9h 1 ; code_immediat 0C9h 1  # fxch st(1) 
 418    code_immediat 0D8h 1 ; code_immediat 0E9h 1  # fsubr st(1) 
 419    code_immediat 0D9h 1 ; code_immediat 0E0h 1  # fchs 
 420    code_immediat 0D9h 1 ; code_immediat 0F0h 1  # f2xm1 
 421    code_immediat 0D9h 1 ; code_immediat 0E8h 1  # fld1 
 422    code_immediat 0DEh 1 ; code_immediat 0C1h 1  # faddp st(1) 
 423    code_immediat 0D9h 1 ; code_immediat 0FDh 1  # fscale 
 424    if not buggy_pow 
 425      f code_immediat 0D9h 1 ; f code_immediat 0C9h 1  # fxch st(1) 
 426      f code_immediat 0D9h 1 ; f code_immediat 0F7h 1  # fincstp 
 427  the_function:power_inline_code set_generate_binary (the_function generate_power_inline_code Instruction Function) 
 428  gvar Int old_debugging_level := pliant_debugging_level_variable ; pliant_debugging_level_variable := 0 
 429  gcc_off 
 430    function 'pliant power raw code' 
 431      power_inline_code 
 432  pliant_debugging_level_variable := old_debugging_level 
 433   
 434  function assemble_power i gc 
 435    arg_rw Instruction i ; arg_rw GeneratorContext gc 
 436    var Pointer:Instruction cur :> i 
 437    cur :> gc insert_after_instruction cur (instruction (the_function i386_fld Float) i:1) 
 438    cur :> gc insert_after_instruction cur (instruction (the_function i386_fld Float) i:0) 
 439    var Link:Instruction ii :> new Instruction 
 440    ii function :> the_function 'pliant power raw code' 
 441    cur :> gc insert_after_instruction cur ii 
 442    cur :> gc insert_after_instruction cur (instruction (the_function i386_fstp Float) i:2) 
 443    cur :> gc insert_after_instruction cur (instruction the_function:i386_wait) 
 444    if buggy_pow 
 445      cur :> gc insert_after_instruction cur (instruction the_function:i386_finit) 
 446    gc remove i 
 447   
 448  function '^' x y -> r 
 449    arg Float r 
 450    if buggy_pow 
 451      gcc_inline (constant "asm volatile( [dq]fldl (%1)\n[dq] [dq]fldl (%0)\n[dq] [dq]call "+'convert to string':(cast the_function:'pliant power raw code':executable Int)+"\n[dq] [dq]fstpl (%2)\n[dq] [dq]fwait\n[dq] [dq]finit\n[dq] : : [dq]r[dq]((int)@1) , [dq]r[dq]((int)@2) , [dq]r[dq]((int)@3) : [dq]memory[dq]);") 
 452    else 
 453      gcc_inline (constant "asm volatile( [dq]fldl (%1)\n[dq] [dq]fldl (%0)\n[dq] [dq]call "+'convert to string':(cast the_function:'pliant power raw code':executable Int)+"\n[dq] [dq]fstpl (%2)\n[dq] [dq]fwait\n[dq] : : [dq]r[dq]((int)@1) , [dq]r[dq]((int)@2) , [dq]r[dq]((int)@3) : [dq]memory[dq]);") 
 454  (the_function '^' Float Float -> Float) set_generate_assembly (the_function assemble_power Instruction GeneratorContext) 
 455   
 456   
 457  function fmod_inline_code 
 458    void 
 459  function generate_fmod_inline_code i f 
 460    arg_rw Instruction i ; arg_rw Function f 
 461    code_immediat 0D9h 1 ; code_immediat 0F8h 1  # fprem 
 462    code_immediat 0DFh 1 ; code_immediat 0E0h 1  # fnstsw ax 
 463    code_immediat 09Eh 1                           # sahf 
 464    code_immediat 07Ah 1 ; code_immediat 0F9h 1  # jp <beginning> 
 465    code_immediat 0DDh 1 ; code_immediat 0D9h 1  # ftsp st(1) 
 466  the_function:fmod_inline_code set_generate_binary (the_function generate_fmod_inline_code Instruction Function) 
 467  old_debugging_level := pliant_debugging_level_variable ; pliant_debugging_level_variable := 0 
 468  function fmod_raw_code 
 469    fmod_inline_code 
 470  pliant_debugging_level_variable := old_debugging_level 
 471   
 472  function assemble_fmod i gc 
 473    arg_rw Instruction i ; arg_rw GeneratorContext gc 
 474    var Pointer:Instruction cur :> i 
 475    cur :> gc insert_after_instruction cur (instruction (the_function i386_fld Float) i:1) 
 476    cur :> gc insert_after_instruction cur (instruction (the_function i386_fld Float) i:0) 
 477    var Link:Instruction ii :> new Instruction 
 478    ii function :> the_function fmod_raw_code 
 479    cur :> gc insert_after_instruction cur ii 
 480    cur :> gc insert_after_instruction cur (instruction (the_function i386_fstp Float) i:2) 
 481    cur :> gc insert_after_instruction cur (instruction the_function:i386_wait) 
 482    gc remove i 
 483   
 484  function '%' x y -> r 
 485    arg Float r 
 486  (the_function '%' Float Float -> Float) set_generate_assembly (the_function assemble_fmod Instruction GeneratorContext) 
 487   
 488   
 489  method data 'from string' string options may_skip skiped offset -> status 
 490    arg_w Float data ; arg Str string options ; arg CBool may_skip ; arg_w Int skiped offset ; arg Status status 
 491    var Int stop := string:len-1 
 492    if not may_skip and stop<>(-1) 
 493      stop := 0 
 494    for (var Int i) stop 
 495      var Int c0 := string:number 
 496      if c0>="0":0:number and c0<="9":0:number or c0="?":0:number or (c0="-":0:number and i+1<>string:len and string:(i+1):number>="0":0:number and string:(i+1):number<="9":0:number) 
 497        skiped := i 
 498        if c0="?":0:number 
 499          data := undefined 
 500          offset := i+1 
 501          return success 
 502        data := 0 ; var Int sign := 1 
 503        if c0="-":0:number 
 504          sign := -1 
 505          := i+1 
 506        while i<string:len and string:i:number>="0":0:number and string:i:number<="9":0:number 
 507          data := data*10 string:i:number-"0":0:number 
 508          := i+1 
 509        if i<string:len and string:i:number=".":0:number 
 510          := i+1 
 511          var Float deci := 1 
 512          while i<string:len and string:i:number>="0":0:number and string:i:number<="9":0:number 
 513            deci := deci/10 
 514            data := data + (string:i:number-"0":0:number)*deci 
 515            := i+1 
 516        if i<string:len and (string:i:number="e":0:number or string:i:number="E":0:number) 
 517          if (from_string addressof:(var Int expo) Int (string i+string:len) "" false (var Int skiped2) (var Int offset2))=success 
 518            data := data * (cast 10 Float)^expo 
 519            := i+1+offset2 
 520        data := data sign 
 521        offset := i 
 522        return success 
 523    data := undefined 
 524    status := shunt string="" and options="db" success failure 
 525   
 526   
 527  function parse_float context line parameter 
 528    arg_rw ParserContext context ; arg Str line ; arg Address parameter 
 529    if (from_string addressof:(var Float data) Float line "" false (var Int skip) (var Int offset))=failure 
 530      return 
 531    if ((line offset) search "." -1)=(-1) and ((line offset) search "e" -1)=(-1) and ((line offset) search "E" -1)=(-1) 
 532      return 
 533    if line:0:number="-":0:number or line:0:number="?":0:number 
 534      return 
 535    if offset<>line:len and line:offset:isidentcharacter 
 536      return 
 537    var Link:Float :> new Float 
 538    := data 
 539    context add_token addressof:f 
 540    context forward offset 
 541   
 542  gvar ParserFilter float_filter 
 543  float_filter function :> the_function parse_float ParserContext Str Address 
 544  constant 'pliant parser basic types' float_filter 
 545  export 'pliant parser basic types' 
 546   
 547   
 548  function compare a b -> c 
 549    arg Float b ; arg Int c 
 550    gcc_inline "$3 = *(double *)@1<*(double *)@2 ? "+'convert to string':compare_inferior+" : *(double *)@1>*(double *)@2 ? "+'convert to string':compare_superior+" : "+'convert to string':compare_equal+";" 
 551    gcc_inline_compare "$3 = *(double *)@1 compare *(double *)@2;" 
 552    var Int := compare_Float b 
 553    if (.and. 2^14+2^8)=2^14+2^8 
 554      return (compare (cast Status) (cast Status)) 
 555    eif (.and. 2^14)<>0 
 556      return compare_equal 
 557    eif (.and. 2^8)<>0 
 558      return compare_inferior 
 559    else 
 560      return compare_superior 
 561   
 562  function compare a b -> c 
 563    arg Float32 b ; arg Int c 
 564    gcc_inline "$3 = *(float *)@1<*(float *)@2 ? "+'convert to string':compare_inferior+" : *(float *)@1>*(float *)@2 ? "+'convert to string':compare_superior+" : "+'convert to string':compare_equal+";" 
 565    gcc_inline_compare "$3 = *(float *)@1 compare *(float *)@2;" 
 566    var Int := compare_Float32 b 
 567    if (.and. 2^14+2^8)=2^14+2^8 
 568      return (compare (cast Status) (cast Status)) 
 569    eif (.and. 2^14)<>0 
 570      return compare_equal 
 571    eif (.and. 2^8)<>0 
 572      return compare_inferior 
 573    else 
 574      return compare_superior 
 575   
 576   
 577  function display_float ff dig_maxi dec_mini dec_maxi e_mini e_maxi undef -> s 
 578    arg Float ff ; arg Int dig_maxi dec_mini dec_maxi e_mini e_maxi ; arg Str undef ; arg Str s 
 579    if dig_maxi<=0 
 580      error error_id_unexpected "out of range dig_maxi" 
 581    if dec_mini<or dec_maxi<dec_mini 
 582      error error_id_unexpected "out of range dec_mini or dec_maxi" 
 583    if ff=undefined 
 584      return undef 
 585    var Float f 
 586    if ff>=0 
 587      := "" ; := ff 
 588    else 
 589      := "-" ; := 0-ff 
 590    var Int e 
 591    if f>=1e-300 
 592      := cast log10:f-0.5 Int 
 593    else 
 594      := 0 
 595    if e<=e_mini or e>=e_maxi 
 596      := f/10.0^e 
 597    else 
 598      := 0 
 599    var Int := 0 
 600    while f>=1 
 601      := n+1 ; := f/10 
 602    var Int dec := max (min dec_maxi dig_maxi-n) dec_mini 
 603    var Float delta := 0.1^(n+dec) 
 604    if f+0.5*delta>=1 
 605      := n+1 ; := f/10 
 606      dec := max (min dec_maxi dig_maxi-n) dec_mini 
 607      delta := 0.1^(n+dec) 
 608    := f+0.5*delta 
 609    if n<>0 
 610      for (var Int i) n 
 611        := f*10 ; delta := delta*10 
 612        var Int := min (max (cast f-0.5 Int) 0) 9 
 613        := s+(character "0":0:number+d) 
 614        := f-d 
 615    else 
 616      := s+"0" 
 617    if (f>delta and dec>0) or dec_mini>0 
 618      := s+"." 
 619      var Int := 0 
 620      while (f>delta and i<dec) or i<dec_mini 
 621        := f*10 ; delta := delta*10 
 622        := min (max (cast f-0.5 Int) 0) 9 
 623        := s+(character "0":0:number+d) 
 624        := f-d 
 625        := i+1 
 626    eif n=0 
 627      := "0" 
 628    if e<>0 
 629      := s+"e"+('convert to string' e) 
 630   
 631  method data 'to string' options -> string 
 632    arg Float32 data ; arg Str options string 
 633    if options:len=and (options 0 6)="fixed " 
 634      var Int fixed := options:6:number-"0":number 
 635      string := display_float data fixed fixed -6 6 "" 
 636    else 
 637      string := display_float data 6 0 6 -6 6 (shunt options="db" or options="raw" "" "?") 
 638   
 639  method data 'to string' options -> string 
 640    arg Float data ; arg Str options string 
 641    if options:len=and (options 0 6)="fixed " 
 642      var Int fixed := options:6:number-"0":number 
 643      string := display_float data 12 fixed fixed -12 12 "" 
 644    else 
 645      string := display_float data 12 0 12 -12 12 (shunt options="db" or options="raw" "" "?") 
 646   
 647   
 648  function '-' a -> r 
 649    arg Float r 
 650    gcc_inline "*(double *)@2 = - *(double *)@1;" 
 651    := 0.0-a 
 652   
 653   
 654  function '-' u -> i 
 655    arg uInt u ; arg Int i 
 656    gcc_inline "$2 = - $1;" 
 657    := -(cast Int) 
 658  # todo: add inline assembly for the_function '-' Int -> Int 
 659  # (the_function '-' uInt -> Int) set_generate_assembly (the_function '-' Int -> Int):generate_assembly 
 660   
 661  function i386_fld64 i64 
 662    arg Int i64 
 663  function generate_i386_fld_int64 i f 
 664    arg_rw Instruction i ; arg_rw Function f 
 665    i386_regmem 11011111b 1 101b i:0 
 666  (the_function i386_fld64 Int) set_generate_binary (the_function generate_i386_fld_int64 Instruction Function) 
 667   
 668  function cast_uInt_Float u -> f 
 669    arg uInt u ; arg Float f 
 670    extension 
 671    gcc_inline "*(double *)@2 = (unsigned int)$1;" 
 672    if u<2^31 
 673      := cast_Int_Float (cast Int) 
 674    else 
 675      := 2.0^31+cast_Int_Float:(cast .-. 2^31 Int) 
 676   
 677  function assemble_cast_uInt_Float i gc 
 678    arg_rw Instruction i ; arg_rw GeneratorContext gc 
 679    var Pointer:Instruction cur :> i 
 680    cur :> gc insert_after_instruction cur (instruction (the_function i386_push Int) (argument constant Int 0)) 
 681    cur :> gc insert_after_instruction cur (instruction (the_function i386_push Int) i:0) 
 682    cur :> gc insert_after_instruction cur (instruction (the_function i386_fld64 Int) (argument indirect Int (gc register i386_esp) 0)) 
 683    cur :> gc insert_after_instruction cur (instruction (the_function i386_add Int Int) (argument constant Int 8) (gc register i386_esp)) 
 684    check i:1:where=argument_indirect 
 685    cur :> gc insert_after_instruction cur (instruction (the_function i386_fstp Float) i:1) 
 686    cur :> gc insert_after_instruction cur (instruction the_function:i386_wait) 
 687    gc remove i 
 688  # (the_function cast_uInt_Float uInt -> Float) set_generate_assembly (the_function assemble_cast_uInt_Float Instruction GeneratorContext) 
 689  # known bug: assemble_cast_uInt_Float breaks some programs 
 690   
 691  alias 'cast Float' cast_uInt_Float in "/pliant/language/basic/ultrasafe.pli" 
 692   
 693   
 694  export Float Float32 Float64 '+' '-' '*' '/' 
 695  export 'cast Int' 'cast Float' 'cast Float32' 'cast Status' compare 
 696  export abs log10 '^' '%' 
 697  export display_float parse_float 
 698   
 699   
 700  if do_init 
 701    i386_finit 
 702    function init_coprocessor p fh 
 703      arg Address p ; arg Int fh 
 704      i386_finit 
 705    gvar DelayedAction restore 
 706    restore function :> the_function init_coprocessor Address Int 
 707    pliant_restore_actions append addressof:restore 
 708   
 709   
 710  function min f1 f2 -> f 
 711    arg Float f1 f2 f 
 712    weak_definition 
 713    := shunt f1<=f2 f1 f2 
 714   
 715  function max f1 f2 -> f 
 716    arg Float f1 f2 f 
 717    weak_definition 
 718    := shunt f1>=f2 f1 f2 
 719   
 720  export min max