Patch title: Release 94 bulk changes
Abstract:
File: /pliant/language/type/number/float.pli
Key:
    Removed line
    Added line
# Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License version 2
# as published by the Free Software Foundation.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# version 2 along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.

scope "/pliant/language/" "/pliant/install/"
module "/pliant/install/ring2.pli"

constant do_init true
constant buggy_pow true


type Float
  field Int low high

alias Float64 Float


type Float32
  field Int value
(addressof:Float32 map Type) flags := Float32:flags .and. .not. type_flag_atomic


if do_init
  function i386_finit
    void
  function generate_i386_finit i f
    arg_rw Instruction i ; arg_rw Function f
    f code_immediat 11011011b 1 ; f code_immediat 11100011b 1
  (the_function i386_finit) set_generate_binary (the_function generate_i386_finit Instruction Function)


function i386_wait
  void
function generate_i386_wait i f
  arg_rw Instruction i ; arg_rw Function f
  f code_immediat 10011011b 1
(the_function i386_wait) set_generate_binary (the_function generate_i386_wait Instruction Function)


function i386_fld f
  arg Float f
function generate_i386_fld64 i f
  arg_rw Instruction i ; arg_rw Function f
  i386_regmem f 11011101b 1 000b i:0
(the_function i386_fld Float) set_generate_binary (the_function generate_i386_fld64 Instruction Function)

function i386_fld f
  arg Float32 f
function generate_i386_fld32 i f
  arg_rw Instruction i ; arg_rw Function f
  i386_regmem f 11011001b 1 000b i:0
(the_function i386_fld Float32) set_generate_binary (the_function generate_i386_fld32 Instruction Function)


function i386_fstp f
  arg_w Float f
function generate_i386_fstp64 i f
  arg_rw Instruction i ; arg_rw Function f
  i386_regmem f 11011101b 1 011b i:0
(the_function i386_fstp Float) set_generate_binary (the_function generate_i386_fstp64 Instruction Function)

function i386_fstp f
  arg_w Float32 f
function generate_i386_fstp32 i f
  arg_rw Instruction i ; arg_rw Function f
  i386_regmem f 11011001b 1 011b i:0
(the_function i386_fstp Float32) set_generate_binary (the_function generate_i386_fstp32 Instruction Function)


function i386_fincstp
  void
function generate_i386_fincstp i f
  arg_rw Instruction i ; arg_rw Function f
  f code_immediat 0D9h 1 ; f code_immediat 0F7h 1 
(the_function i386_fincstp) set_generate_binary (the_function generate_i386_fincstp Instruction Function)


function i386_faddp
  void
function generate_i386_faddp i f
  arg_rw Instruction i ; arg_rw Function f
  f code_immediat 11011110b 1 ; f code_immediat 11000000b+1 1
the_function:i386_faddp set_generate_binary (the_function generate_i386_faddp Instruction Function)

function i386_fadd f
  arg Float f
function generate_i386_fadd i f
  arg_rw Instruction i ; arg_rw Function f
  i386_regmem f 11011100b 1 000b i:0
(the_function i386_fadd Float) set_generate_binary (the_function generate_i386_fadd Instruction Function)

function '+' a b -> r
  arg Float a b r
  gcc_inline "*(double *)@3 = *(double *)@1 + *(double *)@2;"
function assemble_plus_Float i gc
  arg_rw Instruction i ; arg_rw GeneratorContext gc
  var Pointer:Instruction cur :> i
  cur :> gc insert_after_instruction cur (instruction (the_function i386_fld Float) i:0)
  cur :> gc insert_after_instruction cur (instruction (the_function i386_fadd Float) i:1)
  cur :> gc insert_after_instruction cur (instruction (the_function i386_fstp Float) i:2)
  cur :> gc insert_after_instruction cur (instruction the_function:i386_wait)
  gc remove i
(the_function '+' Float Float -> Float) set_generate_assembly (the_function assemble_plus_Float Instruction GeneratorContext)


function i386_fsub f
  arg Float f
function generate_i386_fsub i f
  arg_rw Instruction i ; arg_rw Function f
  i386_regmem f 11011100b 1 100b i:0
(the_function i386_fsub Float) set_generate_binary (the_function generate_i386_fsub Instruction Function)

function '-' a b -> r
  arg Float a b r
  gcc_inline "*(double *)@3 = *(double *)@1 - *(double *)@2;"
function assemble_minus_Float i gc
  arg_rw Instruction i ; arg_rw GeneratorContext gc
  var Pointer:Instruction cur :> i
  cur :> gc insert_after_instruction cur (instruction (the_function i386_fld Float) i:0)
  cur :> gc insert_after_instruction cur (instruction (the_function i386_fsub Float) i:1)
  cur :> gc insert_after_instruction cur (instruction (the_function i386_fstp Float) i:2)
  cur :> gc insert_after_instruction cur (instruction the_function:i386_wait)
  gc remove i
(the_function '-' Float Float -> Float) set_generate_assembly (the_function assemble_minus_Float Instruction GeneratorContext)


function i386_fmul f
  arg Float f
function generate_i386_fmul i f
  arg_rw Instruction i ; arg_rw Function f
  i386_regmem f 11011100b 1 001b i:0
(the_function i386_fmul Float) set_generate_binary (the_function generate_i386_fmul Instruction Function)

function '*' a b -> r
  arg Float a b r
  gcc_inline "*(double *)@3 = *(double *)@1 * *(double *)@2;"
function assemble_multiply_Float i gc
  arg_rw Instruction i ; arg_rw GeneratorContext gc
  var Pointer:Instruction cur :> i
  cur :> gc insert_after_instruction cur (instruction (the_function i386_fld Float) i:0)
  cur :> gc insert_after_instruction cur (instruction (the_function i386_fmul Float) i:1)
  cur :> gc insert_after_instruction cur (instruction (the_function i386_fstp Float) i:2)
  cur :> gc insert_after_instruction cur (instruction the_function:i386_wait)
  gc remove i
(the_function '*' Float Float -> Float) set_generate_assembly (the_function assemble_multiply_Float Instruction GeneratorContext)


function i386_fdiv f
  arg Float f
function generate_i386_fdiv i f
  arg_rw Instruction i ; arg_rw Function f
  i386_regmem f 11011100b 1 110b i:0
(the_function i386_fdiv Float) set_generate_binary (the_function generate_i386_fdiv Instruction Function)

function '/' a b -> r
  arg Float a b r
  gcc_inline "*(double *)@3 = *(double *)@1 / *(double *)@2;"
function assemble_divide_Float i gc
  arg_rw Instruction i ; arg_rw GeneratorContext gc
  var Pointer:Instruction cur :> i
  cur :> gc insert_after_instruction cur (instruction (the_function i386_fld Float) i:0)
  cur :> gc insert_after_instruction cur (instruction (the_function i386_fdiv Float) i:1)
  cur :> gc insert_after_instruction cur (instruction (the_function i386_fstp Float) i:2)
  cur :> gc insert_after_instruction cur (instruction the_function:i386_wait)
  gc remove i
(the_function '/' Float Float -> Float) set_generate_assembly (the_function assemble_divide_Float Instruction GeneratorContext)


function i386_fcomp f
  arg Float f
function generate_i386_fcomp i f
  arg_rw Instruction i ; arg_rw Function f
  i386_regmem f 11011100b 1 011b i:0
(the_function i386_fcomp Float) set_generate_binary (the_function generate_i386_fcomp Instruction Function)

function i386_fstsw_ax r
  arg_w Int r
function generate_i386_fstsw_ax i f
  arg_rw Instruction i ; arg_rw Function f
  if i:0:where=argument_register and i:0:register=i386_eax
    f code_immediat 11011111b 1 ; f code_immediat 11100000b 1
  else
    error error_id_unexpected "Expected eax"
(the_function i386_fstsw_ax Int) set_generate_binary (the_function generate_i386_fstsw_ax Instruction Function)

function compare_Float a b -> c
  arg Float a b ; arg Int c
  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+";"
  gcc_inline_compare "$3 = *(double *)@1 compare *(double *)@2;"
function assemble_compare_Float i gc
  arg_rw Instruction i ; arg_rw GeneratorContext gc
  var Pointer:Instruction cur :> i
  cur :> gc insert_after_instruction cur (instruction (the_function i386_fld Float) i:0)
  cur :> gc insert_after_instruction cur (instruction (the_function i386_fcomp Float) i:1)
  cur :> gc insert_after_instruction cur (instruction (the_function i386_fstsw_ax Int) (gc register i386_eax))
  cur :> gc insert_after_instruction cur (instruction (the_function i386_mov Int Int) (gc register i386_eax) i:2)
  gc remove i
(the_function compare_Float Float Float -> Int) set_generate_assembly (the_function assemble_compare_Float Instruction GeneratorContext)


function i386_fcomp f32
  arg Float32 f32
function generate_i386_fcomp32 i f
  arg_rw Instruction i ; arg_rw Function f
  i386_regmem f 11011000b 1 011b i:0
(the_function i386_fcomp Float32) set_generate_binary (the_function generate_i386_fcomp32 Instruction Function)

function compare_Float32 a b -> c
  arg Float32 a b ; arg Int c
  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+";"
  gcc_inline_compare "$3 = *(float *)@1 compare *(float *)@2;"
function assemble_compare_Float32 i gc
  arg_rw Instruction i ; arg_rw GeneratorContext gc
  var Pointer:Instruction cur :> i
  cur :> gc insert_after_instruction cur (instruction (the_function i386_fld Float32) i:0)
  cur :> gc insert_after_instruction cur (instruction (the_function i386_fcomp Float32) i:1)
  cur :> gc insert_after_instruction cur (instruction (the_function i386_fstsw_ax Int) (gc register i386_eax))
  cur :> gc insert_after_instruction cur (instruction (the_function i386_mov Int Int) (gc register i386_eax) i:2)
  gc remove i
(the_function compare_Float32 Float32 Float32 -> Int) set_generate_assembly (the_function assemble_compare_Float32 Instruction GeneratorContext)


function i386_frndint
  void
function generate_i386_frndint i f
  arg_rw Instruction i ; arg_rw Function f
  f code_immediat 11011001b 1 ; f code_immediat 11111100b 1
the_function:i386_frndint set_generate_binary (the_function generate_i386_frndint Instruction Function)

function i386_fstp i
  arg Int i
function generate_i386_fstp_int i f
  arg_rw Instruction i ; arg_rw Function f
  i386_regmem f 11011011b 1 011b i:0
(the_function i386_fstp Int) set_generate_binary (the_function generate_i386_fstp_int Instruction Function)

function 'cast Int' f -> i
  arg Float f ; arg Int i
  gcc_inline "$2 = (int)(*(double *)@1+0.5);"
function assemble_cast_Float_Int i gc
  arg_rw Instruction i ; arg_rw GeneratorContext gc
  var Pointer:Instruction cur :> i
  cur :> gc insert_after_instruction cur (instruction (the_function i386_fld Float) i:0)
  cur :> gc insert_after_instruction cur (instruction the_function:i386_frndint)
  if i:1:where=argument_indirect
    cur :> gc insert_after_instruction cur (instruction (the_function i386_fstp Int) i:1)
  else
    cur :> gc insert_after_instruction cur (instruction (the_function i386_add Int Int) (argument constant Int -4) (gc register i386_esp))
    cur :> gc insert_after_instruction cur (instruction (the_function i386_fstp Int) (argument indirect Int (gc register i386_esp) 0))
    cur :> gc insert_after_instruction cur (instruction (the_function i386_pop Int) i:1)
  cur :> gc insert_after_instruction cur (instruction the_function:i386_wait)
  gc remove i
(the_function 'cast Int' Float -> Int) set_generate_assembly (the_function assemble_cast_Float_Int Instruction GeneratorContext)


function i386_fld i
  arg Int i
function generate_i386_fld_int i f
  arg_rw Instruction i ; arg_rw Function f
  if i:0:where=argument_constant
    var Link:Int imm :> new Int ; imm := i:0:constant map Int
    f record_external addressof:imm false
    i386_memory f 11011011b 1 000b undefined undefined 1 (cast addressof:imm Int)
  else
    i386_regmem f 11011011b 1 000b i:0
(the_function i386_fld Int) set_generate_binary (the_function generate_i386_fld_int Instruction Function)

function cast_Int_Float i -> f
  arg Int i ; arg Float f
  extension
  gcc_inline "*(double *)@2 = $1;"
function assemble_cast_Int_Float i gc
  arg_rw Instruction i ; arg_rw GeneratorContext gc
  var Pointer:Instruction cur :> i
  if i:0:where=argument_indirect
    cur :> gc insert_after_instruction cur (instruction (the_function i386_fld Int) i:0)
  else
    cur :> gc insert_after_instruction cur (instruction (the_function i386_push Int) i:0)
    cur :> gc insert_after_instruction cur (instruction (the_function i386_fld Int) (argument indirect Int (gc register i386_esp) 0))
    cur :> gc insert_after_instruction cur (instruction (the_function i386_add Int Int) (argument constant Int 4) (gc register i386_esp))
  check i:1:where=argument_indirect
  cur :> gc insert_after_instruction cur (instruction (the_function i386_fstp Float) i:1)
  cur :> gc insert_after_instruction cur (instruction the_function:i386_wait)
  gc remove i
(the_function cast_Int_Float Int -> Float) set_generate_assembly (the_function assemble_cast_Int_Float Instruction GeneratorContext)

alias 'cast Float' cast_Int_Float in "/pliant/language/basic/ultrasafe.pli"


function 'cast Float' f32 -> f
  arg Float32 f32 ; arg Float f
  extension
  gcc_inline "*(double *)@2 = *(float *)@1;"
function assemble_cast_Float32_Float i gc
  arg_rw Instruction i ; arg_rw GeneratorContext gc
  var Pointer:Instruction cur :> i
  cur :> gc insert_after_instruction cur (instruction (the_function i386_fld Float32) i:0)
  cur :> gc insert_after_instruction cur (instruction (the_function i386_fstp Float) i:1)
  cur :> gc insert_after_instruction cur (instruction the_function:i386_wait)
  gc remove i
(the_function 'cast Float' Float32 -> Float) set_generate_assembly (the_function assemble_cast_Float32_Float Instruction GeneratorContext)

function 'cast Float32' f -> f32
  arg Float f ; arg Float32 f32
  reduction
  gcc_inline "*(float *)@2 = *(double *)@1;"
function assemble_cast_Float_Float32 i gc
  arg_rw Instruction i ; arg_rw GeneratorContext gc
  var Pointer:Instruction cur :> i
  cur :> gc insert_after_instruction cur (instruction (the_function i386_fld Float) i:0)
  cur :> gc insert_after_instruction cur (instruction (the_function i386_fstp Float32) i:1)
  cur :> gc insert_after_instruction cur (instruction the_function:i386_wait)
  gc remove i
(the_function 'cast Float32' Float -> Float32) set_generate_assembly (the_function assemble_cast_Float_Float32 Instruction GeneratorContext)


module "/pliant/language/type/misc/status.pli"

function 'cast Status' f -> s
  arg Float f ; arg Status s
  explicit
  if (f:high .and. 7FF00000h)=7FF00000h
    s := undefined
  else
    s := defined

function 'cast Float' s -> f
  arg Status s ; arg Float f
  extension
  if s<>undefined
    error error_id_unexpected "Unexpected Status value"
  f low := -1 ; f high := -1

function 'cast Status' f32 -> s
  arg Float32 f32 ; arg Status s
  explicit
  if (f32:value .and. 7F800000h)=7F800000h
    s := undefined
  else
    s := defined

function 'cast Float32' s -> f32
  arg Status s ; arg Float32 f32
  extension
  if s<>undefined
    error error_id_unexpected "Unexpected Status value"
  f32 value := -1

function i386_fabs
  void
function generate_i386_fabs i f
  arg_rw Instruction i ; arg_rw Function f
  f code_immediat 11011001b 1 ; f code_immediat 11100001b 1
the_function:i386_fabs set_generate_binary (the_function generate_i386_fabs Instruction Function)

function abs f -> r
  arg Float f r
  gcc_inline "*(double *)@2 = (*(double *)@1>=0 ? *(double *)@1 : -*(double *)@1);"
function assemble_abs_Float i gc
  arg_rw Instruction i ; arg_rw GeneratorContext gc
  var Pointer:Instruction cur :> i
  cur :> gc insert_after_instruction cur (instruction (the_function i386_fld Float) i:0)
  cur :> gc insert_after_instruction cur (instruction the_function:i386_fabs)
  cur :> gc insert_after_instruction cur (instruction (the_function i386_fstp Float) i:1)
  cur :> gc insert_after_instruction cur (instruction the_function:i386_wait)
  gc remove i
(the_function abs Float -> Float) set_generate_assembly (the_function assemble_abs_Float Instruction GeneratorContext)


function i386_fyl2x
  void
function generate_i386_fyl2x i f
  arg_rw Instruction i ; arg_rw Function f
  f code_immediat 11011001b 1 ; f code_immediat 11110001b 1
the_function:i386_fyl2x set_generate_binary (the_function generate_i386_fyl2x Instruction Function)

function i386_fldlg2
  void
function generate_i386_fldlg2 i f
  arg_rw Instruction i ; arg_rw Function f
  f code_immediat 11011001b 1 ; f code_immediat 11101100b 1
the_function:i386_fldlg2 set_generate_binary (the_function generate_i386_fldlg2 Instruction Function)

function log10 f -> r
  arg Float f r
  gcc_inline "asm( [dq]fldlg2\n[dq] [dq]fxch\n[dq] [dq]fyl2x[dq] : [dq]=t[dq] (*(double *)@2) : [dq]0[dq] (*(double *)@1));"
function assemble_log10_Float i gc
  arg_rw Instruction i ; arg_rw GeneratorContext gc
  var Pointer:Instruction cur :> i
  cur :> gc insert_after_instruction cur (instruction the_function:i386_fldlg2)
  cur :> gc insert_after_instruction cur (instruction (the_function i386_fld Float) i:0)
  cur :> gc insert_after_instruction cur (instruction the_function:i386_fyl2x)
  cur :> gc insert_after_instruction cur (instruction (the_function i386_fstp Float) i:1)
  cur :> gc insert_after_instruction cur (instruction the_function:i386_wait)
  gc remove i
(the_function log10 Float -> Float) set_generate_assembly (the_function assemble_log10_Float Instruction GeneratorContext)


function power_inline_code
  void
function generate_power_inline_code i f
  arg_rw Instruction i ; arg_rw Function f
  f code_immediat 0D9h 1 ; f code_immediat 0F1h 1  # fyl2x
  f code_immediat 0D9h 1 ; f code_immediat 0C0h 1  # fld st(0)
  f code_immediat 0D9h 1 ; f code_immediat 0FCh 1  # frndint
  f code_immediat 0D9h 1 ; f code_immediat 0C9h 1  # fxch st(1)
  f code_immediat 0D8h 1 ; f code_immediat 0E9h 1  # fsubr st(1)
  f code_immediat 0D9h 1 ; f code_immediat 0E0h 1  # fchs
  f code_immediat 0D9h 1 ; f code_immediat 0F0h 1  # f2xm1
  f code_immediat 0D9h 1 ; f code_immediat 0E8h 1  # fld1
  f code_immediat 0DEh 1 ; f code_immediat 0C1h 1  # faddp st(1)
  f code_immediat 0D9h 1 ; f code_immediat 0FDh 1  # fscale
  if not buggy_pow
    f code_immediat 0D9h 1 ; f code_immediat 0C9h 1  # fxch st(1)
    f code_immediat 0D9h 1 ; f code_immediat 0F7h 1  # fincstp
the_function:power_inline_code set_generate_binary (the_function generate_power_inline_code Instruction Function)
gvar Int old_debugging_level := pliant_debugging_level_variable ; pliant_debugging_level_variable := 0
gcc_off
  function 'pliant power raw code'
    power_inline_code
pliant_debugging_level_variable := old_debugging_level

function assemble_power i gc
  arg_rw Instruction i ; arg_rw GeneratorContext gc
  var Pointer:Instruction cur :> i
  cur :> gc insert_after_instruction cur (instruction (the_function i386_fld Float) i:1)
  cur :> gc insert_after_instruction cur (instruction (the_function i386_fld Float) i:0)
  var Link:Instruction ii :> new Instruction
  ii function :> the_function 'pliant power raw code'
  cur :> gc insert_after_instruction cur ii
  cur :> gc insert_after_instruction cur (instruction (the_function i386_fstp Float) i:2)
  cur :> gc insert_after_instruction cur (instruction the_function:i386_wait)
  if buggy_pow
    cur :> gc insert_after_instruction cur (instruction the_function:i386_finit)
  gc remove i

function '^' x y -> r
  arg Float x y r
  if buggy_pow
    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]);")
  else
    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]);")
(the_function '^' Float Float -> Float) set_generate_assembly (the_function assemble_power Instruction GeneratorContext)


function fmod_inline_code
  void
function generate_fmod_inline_code i f
  arg_rw Instruction i ; arg_rw Function f
  f code_immediat 0D9h 1 ; f code_immediat 0F8h 1  # fprem
  f code_immediat 0DFh 1 ; f code_immediat 0E0h 1  # fnstsw ax
  f code_immediat 09Eh 1                           # sahf
  f code_immediat 07Ah 1 ; f code_immediat 0F9h 1  # jp <beginning>
  f code_immediat 0DDh 1 ; f code_immediat 0D9h 1  # ftsp st(1)
the_function:fmod_inline_code set_generate_binary (the_function generate_fmod_inline_code Instruction Function)
old_debugging_level := pliant_debugging_level_variable ; pliant_debugging_level_variable := 0
function fmod_raw_code
  fmod_inline_code
pliant_debugging_level_variable := old_debugging_level

function assemble_fmod i gc
  arg_rw Instruction i ; arg_rw GeneratorContext gc
  var Pointer:Instruction cur :> i
  cur :> gc insert_after_instruction cur (instruction (the_function i386_fld Float) i:1)
  cur :> gc insert_after_instruction cur (instruction (the_function i386_fld Float) i:0)
  var Link:Instruction ii :> new Instruction
  ii function :> the_function fmod_raw_code
  cur :> gc insert_after_instruction cur ii
  cur :> gc insert_after_instruction cur (instruction (the_function i386_fstp Float) i:2)
  cur :> gc insert_after_instruction cur (instruction the_function:i386_wait)
  gc remove i

function '%' x y -> r
  arg Float x y r
(the_function '%' Float Float -> Float) set_generate_assembly (the_function assemble_fmod Instruction GeneratorContext)


method data 'from string' string options may_skip skiped offset -> status
  arg_w Float data ; arg Str string options ; arg CBool may_skip ; arg_w Int skiped offset ; arg Status status
  var Int stop := string:len-1
  if not may_skip and stop<>(-1)
    stop := 0
  for (var Int i) 0 stop
    var Int c0 := string:i number
    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)
      skiped := i
      if c0="?":0:number
        data := undefined
        offset := i+1
        return success
      data := 0 ; var Int sign := 1
      if c0="-":0:number
        sign := -1
        i := i+1
      while i<string:len and string:i:number>="0":0:number and string:i:number<="9":0:number
        data := data*10 + string:i:number-"0":0:number
        i := i+1
      if i<string:len and string:i:number=".":0:number
        i := i+1
        var Float deci := 1
        while i<string:len and string:i:number>="0":0:number and string:i:number<="9":0:number
          deci := deci/10
          data := data + (string:i:number-"0":0:number)*deci
          i := i+1
      if i<string:len and (string:i:number="e":0:number or string:i:number="E":0:number)
        if (from_string addressof:(var Int expo) Int (string i+1 string:len) "" false (var Int skiped2) (var Int offset2))=success
          data := data * (cast 10 Float)^expo
          i := i+1+offset2
      data := data * sign
      offset := i
      return success
  data := undefined
  status := shunt string="" and options="db" success failure


function parse_float context line parameter
  arg_rw ParserContext context ; arg Str line ; arg Address parameter
  if (from_string addressof:(var Float data) Float line "" false (var Int skip) (var Int offset))=failure
    return
  if ((line 0 offset) search "." -1)=(-1) and ((line 0 offset) search "e" -1)=(-1) and ((line 0 offset) search "E" -1)=(-1)
    return
  if line:0:number="-":0:number or line:0:number="?":0:number
    return
  if offset<>line:len and line:offset:isidentcharacter
    return
  var Link:Float f :> new Float
  f := data
  context add_token addressof:f
  context forward offset

gvar ParserFilter float_filter
float_filter function :> the_function parse_float ParserContext Str Address
constant 'pliant parser basic types' float_filter
export 'pliant parser basic types'


function compare a b -> c
  arg Float a b ; arg Int c
  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+";"
  gcc_inline_compare "$3 = *(double *)@1 compare *(double *)@2;"
  var Int r := compare_Float a b
  if (r .and. 2^14+2^8)=2^14+2^8
    return (compare (cast a Status) (cast b Status))
  eif (r .and. 2^14)<>0
    return compare_equal
  eif (r .and. 2^8)<>0
    return compare_inferior
  else
    return compare_superior

function compare a b -> c
  arg Float32 a b ; arg Int c
  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+";"
  gcc_inline_compare "$3 = *(float *)@1 compare *(float *)@2;"
  var Int r := compare_Float32 a b
  if (r .and. 2^14+2^8)=2^14+2^8
    return (compare (cast a Status) (cast b Status))
  eif (r .and. 2^14)<>0
    return compare_equal
  eif (r .and. 2^8)<>0
    return compare_inferior
  else
    return compare_superior


function display_float ff dig_maxi dec_mini dec_maxi e_mini e_maxi undef -> s
  arg Float ff ; arg Int dig_maxi dec_mini dec_maxi e_mini e_maxi ; arg Str undef ; arg Str s
  if dig_maxi<=0
    error error_id_unexpected "out of range dig_maxi"
  if dec_mini<0 or dec_maxi<dec_mini
    error error_id_unexpected "out of range dec_mini or dec_maxi"
  if ff=undefined
    return undef
  var Float f
  if ff>=0
    s := "" ; f := ff
  else
    s := "-" ; f := 0-ff
  var Int e
  if f>=1e-300
    e := cast log10:f-0.5 Int
  else
    e := 0
  if e<=e_mini or e>=e_maxi
    f := f/10.0^e
  else
    e := 0
  var Int n := 0
  while f>=1
    n := n+1 ; f := f/10
  var Int dec := max (min dec_maxi dig_maxi-n) dec_mini
  var Float delta := 0.1^(n+dec)
  if f+0.5*delta>=1
    n := n+1 ; f := f/10
    dec := max (min dec_maxi dig_maxi-n) dec_mini
    delta := 0.1^(n+dec)
  f := f+0.5*delta
  if n<>0
    for (var Int i) 1 n
      f := f*10 ; delta := delta*10
      var Int d := min (max (cast f-0.5 Int) 0) 9
      s := s+(character "0":0:number+d)
      f := f-d
  else
    s := s+"0"
  if (f>delta and dec>0) or dec_mini>0
    s := s+"."
    var Int i := 0
    while (f>delta and i<dec) or i<dec_mini
      f := f*10 ; delta := delta*10
      d := min (max (cast f-0.5 Int) 0) 9
      s := s+(character "0":0:number+d)
      f := f-d
      i := i+1
  eif n=0
    s := "0"
  if e<>0
    s := s+"e"+('convert to string' e)

method data 'to string' options -> string
  arg Float32 data ; arg Str options string
  if options:len=7 and (options 0 6)="fixed "
    var Int fixed := options:6:number-"0":number
    string := display_float data 6 fixed fixed -6 6 ""
  else
    string := display_float data 6 0 6 -6 6 (shunt options="db" "" "?")
    string := display_float data 6 0 6 -6 6 (shunt options="db" or options="raw" "" "?")

method data 'to string' options -> string
  arg Float data ; arg Str options string
  if options:len=7 and (options 0 6)="fixed "
    var Int fixed := options:6:number-"0":number
    string := display_float data 12 fixed fixed -12 12 ""
  else
    string := display_float data 12 0 12 -12 12 (shunt options="db" "" "?")
    string := display_float data 12 0 12 -12 12 (shunt options="db" or options="raw" "" "?")


function '-' a -> r
  arg Float a r
  gcc_inline "*(double *)@2 = - *(double *)@1;"
  r := 0.0-a


function '-' u -> i
  arg uInt u ; arg Int i
  gcc_inline "$2 = - $1;"
  i := -(cast u Int)
# todo: add inline assembly for the_function '-' Int -> Int
# (the_function '-' uInt -> Int) set_generate_assembly (the_function '-' Int -> Int):generate_assembly

function i386_fld64 i64
  arg Int i64
function generate_i386_fld_int64 i f
  arg_rw Instruction i ; arg_rw Function f
  i386_regmem f 11011111b 1 101b i:0
(the_function i386_fld64 Int) set_generate_binary (the_function generate_i386_fld_int64 Instruction Function)

function cast_uInt_Float u -> f
  arg uInt u ; arg Float f
  extension
  gcc_inline "*(double *)@2 = (unsigned int)$1;"
  if u<2^31
    f := cast_Int_Float (cast u Int)
  else
    f := 2.0^31+cast_Int_Float:(cast u .-. 2^31 Int)

function assemble_cast_uInt_Float i gc
  arg_rw Instruction i ; arg_rw GeneratorContext gc
  var Pointer:Instruction cur :> i
  cur :> gc insert_after_instruction cur (instruction (the_function i386_push Int) (argument constant Int 0))
  cur :> gc insert_after_instruction cur (instruction (the_function i386_push Int) i:0)
  cur :> gc insert_after_instruction cur (instruction (the_function i386_fld64 Int) (argument indirect Int (gc register i386_esp) 0))
  cur :> gc insert_after_instruction cur (instruction (the_function i386_add Int Int) (argument constant Int 8) (gc register i386_esp))
  check i:1:where=argument_indirect
  cur :> gc insert_after_instruction cur (instruction (the_function i386_fstp Float) i:1)
  cur :> gc insert_after_instruction cur (instruction the_function:i386_wait)
  gc remove i
# (the_function cast_uInt_Float uInt -> Float) set_generate_assembly (the_function assemble_cast_uInt_Float Instruction GeneratorContext)
# known bug: assemble_cast_uInt_Float breaks some programs

alias 'cast Float' cast_uInt_Float in "/pliant/language/basic/ultrasafe.pli"


export Float Float32 Float64 '+' '-' '*' '/'
export 'cast Int' 'cast Float' 'cast Float32' 'cast Status' compare
export abs log10 '^' '%'
export display_float parse_float


if do_init
  i386_finit
  function init_coprocessor p fh
    arg Address p ; arg Int fh
    i386_finit
  gvar DelayedAction restore
  restore function :> the_function init_coprocessor Address Int
  pliant_restore_actions append addressof:restore


function min f1 f2 -> f
  arg Float f1 f2 f
  weak_definition
  f := shunt f1<=f2 f1 f2

function max f1 f2 -> f
  arg Float f1 f2 f
  weak_definition
  f := shunt f1>=f2 f1 f2

export min max