src/HOL/Tools/float_syntax.ML
author wenzelm
Wed, 25 Jul 2012 18:05:07 +0200
changeset 48502 fd03877ad5bc
parent 47108 2a1953f0d20d
child 52143 36ffe23b25f8
permissions -rw-r--r--
session specifications for doc-src, excluding TutorialI for now;
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
37744
3daaf23b9ab4 tuned titles
haftmann
parents: 35123
diff changeset
     1
(*  Title:      HOL/Tools/float_syntax.ML
3daaf23b9ab4 tuned titles
haftmann
parents: 35123
diff changeset
     2
    Author:     Tobias Nipkow, TU Muenchen
28906
5f568bfc58d7 Floats for Real.
nipkow
parents:
diff changeset
     3
35115
446c5063e4fd modernized translations;
wenzelm
parents: 32603
diff changeset
     4
Concrete syntax for floats.
28906
5f568bfc58d7 Floats for Real.
nipkow
parents:
diff changeset
     5
*)
5f568bfc58d7 Floats for Real.
nipkow
parents:
diff changeset
     6
5f568bfc58d7 Floats for Real.
nipkow
parents:
diff changeset
     7
signature FLOAT_SYNTAX =
5f568bfc58d7 Floats for Real.
nipkow
parents:
diff changeset
     8
sig
5f568bfc58d7 Floats for Real.
nipkow
parents:
diff changeset
     9
  val setup: theory -> theory
5f568bfc58d7 Floats for Real.
nipkow
parents:
diff changeset
    10
end;
5f568bfc58d7 Floats for Real.
nipkow
parents:
diff changeset
    11
35123
e286d5df187a modernized structures;
wenzelm
parents: 35115
diff changeset
    12
structure Float_Syntax: FLOAT_SYNTAX =
28906
5f568bfc58d7 Floats for Real.
nipkow
parents:
diff changeset
    13
struct
5f568bfc58d7 Floats for Real.
nipkow
parents:
diff changeset
    14
5f568bfc58d7 Floats for Real.
nipkow
parents:
diff changeset
    15
(* parse translation *)
5f568bfc58d7 Floats for Real.
nipkow
parents:
diff changeset
    16
5f568bfc58d7 Floats for Real.
nipkow
parents:
diff changeset
    17
local
5f568bfc58d7 Floats for Real.
nipkow
parents:
diff changeset
    18
5f568bfc58d7 Floats for Real.
nipkow
parents:
diff changeset
    19
fun mk_number i =
5f568bfc58d7 Floats for Real.
nipkow
parents:
diff changeset
    20
  let
47108
2a1953f0d20d merged fork with new numeral representation (see NEWS)
huffman
parents: 46236
diff changeset
    21
    fun mk 1 = Syntax.const @{const_syntax Num.One}
35115
446c5063e4fd modernized translations;
wenzelm
parents: 32603
diff changeset
    22
      | mk i =
446c5063e4fd modernized translations;
wenzelm
parents: 32603
diff changeset
    23
          let val (q, r) = Integer.div_mod i 2
446c5063e4fd modernized translations;
wenzelm
parents: 32603
diff changeset
    24
          in HOLogic.mk_bit r $ (mk q) end;
47108
2a1953f0d20d merged fork with new numeral representation (see NEWS)
huffman
parents: 46236
diff changeset
    25
  in
2a1953f0d20d merged fork with new numeral representation (see NEWS)
huffman
parents: 46236
diff changeset
    26
    if i = 0 then Syntax.const @{const_syntax Groups.zero}
2a1953f0d20d merged fork with new numeral representation (see NEWS)
huffman
parents: 46236
diff changeset
    27
    else if i > 0 then Syntax.const @{const_syntax Num.numeral} $ mk i
2a1953f0d20d merged fork with new numeral representation (see NEWS)
huffman
parents: 46236
diff changeset
    28
    else Syntax.const @{const_syntax Num.neg_numeral} $ mk (~i)
2a1953f0d20d merged fork with new numeral representation (see NEWS)
huffman
parents: 46236
diff changeset
    29
  end;
28906
5f568bfc58d7 Floats for Real.
nipkow
parents:
diff changeset
    30
5f568bfc58d7 Floats for Real.
nipkow
parents:
diff changeset
    31
fun mk_frac str =
5f568bfc58d7 Floats for Real.
nipkow
parents:
diff changeset
    32
  let
42290
b1f544c84040 discontinued special treatment of structure Lexicon;
wenzelm
parents: 37744
diff changeset
    33
    val {mant = i, exp = n} = Lexicon.read_float str;
35115
446c5063e4fd modernized translations;
wenzelm
parents: 32603
diff changeset
    34
    val exp = Syntax.const @{const_syntax Power.power};
28906
5f568bfc58d7 Floats for Real.
nipkow
parents:
diff changeset
    35
    val ten = mk_number 10;
35115
446c5063e4fd modernized translations;
wenzelm
parents: 32603
diff changeset
    36
    val exp10 = if n = 1 then ten else exp $ ten $ mk_number n;
446c5063e4fd modernized translations;
wenzelm
parents: 32603
diff changeset
    37
  in Syntax.const @{const_syntax divide} $ mk_number i $ exp10 end;
446c5063e4fd modernized translations;
wenzelm
parents: 32603
diff changeset
    38
28906
5f568bfc58d7 Floats for Real.
nipkow
parents:
diff changeset
    39
in
5f568bfc58d7 Floats for Real.
nipkow
parents:
diff changeset
    40
46236
ae79f2978a67 position constraints for numerals enable PIDE markup;
wenzelm
parents: 42290
diff changeset
    41
fun float_tr [(c as Const (@{syntax_const "_constrain"}, _)) $ t $ u] = c $ float_tr [t] $ u
ae79f2978a67 position constraints for numerals enable PIDE markup;
wenzelm
parents: 42290
diff changeset
    42
  | float_tr [t as Const (str, _)] = mk_frac str
ae79f2978a67 position constraints for numerals enable PIDE markup;
wenzelm
parents: 42290
diff changeset
    43
  | float_tr ts = raise TERM ("float_tr", ts);
28906
5f568bfc58d7 Floats for Real.
nipkow
parents:
diff changeset
    44
5f568bfc58d7 Floats for Real.
nipkow
parents:
diff changeset
    45
end;
5f568bfc58d7 Floats for Real.
nipkow
parents:
diff changeset
    46
5f568bfc58d7 Floats for Real.
nipkow
parents:
diff changeset
    47
5f568bfc58d7 Floats for Real.
nipkow
parents:
diff changeset
    48
(* theory setup *)
5f568bfc58d7 Floats for Real.
nipkow
parents:
diff changeset
    49
5f568bfc58d7 Floats for Real.
nipkow
parents:
diff changeset
    50
val setup =
35115
446c5063e4fd modernized translations;
wenzelm
parents: 32603
diff changeset
    51
  Sign.add_trfuns ([], [(@{syntax_const "_Float"}, float_tr)], [], []);
28906
5f568bfc58d7 Floats for Real.
nipkow
parents:
diff changeset
    52
5f568bfc58d7 Floats for Real.
nipkow
parents:
diff changeset
    53
end;