294 |
294 |
295 |
295 |
296 subsection {* Syntax *} |
296 subsection {* Syntax *} |
297 |
297 |
298 syntax |
298 syntax |
299 "_NumeralType" :: "num_const => type" ("_") |
299 "_NumeralType" :: "num_token => type" ("_") |
300 "_NumeralType0" :: type ("0") |
300 "_NumeralType0" :: type ("0") |
301 "_NumeralType1" :: type ("1") |
301 "_NumeralType1" :: type ("1") |
302 |
302 |
303 translations |
303 translations |
304 (type) "1" == (type) "num1" |
304 (type) "1" == (type) "num1" |
305 (type) "0" == (type) "num0" |
305 (type) "0" == (type) "num0" |
306 |
306 |
307 parse_translation {* |
307 parse_translation {* |
308 let |
308 let |
309 fun mk_bintype n = |
309 fun mk_bintype n = |
310 let |
310 let |
311 fun mk_bit 0 = Syntax.const @{type_syntax bit0} |
311 fun mk_bit 0 = Syntax.const @{type_syntax bit0} |
312 | mk_bit 1 = Syntax.const @{type_syntax bit1}; |
312 | mk_bit 1 = Syntax.const @{type_syntax bit1}; |
313 fun bin_of n = |
313 fun bin_of n = |
314 if n = 1 then Syntax.const @{type_syntax num1} |
314 if n = 1 then Syntax.const @{type_syntax num1} |
315 else if n = 0 then Syntax.const @{type_syntax num0} |
315 else if n = 0 then Syntax.const @{type_syntax num0} |
316 else if n = ~1 then raise TERM ("negative type numeral", []) |
316 else if n = ~1 then raise TERM ("negative type numeral", []) |
317 else |
317 else |
318 let val (q, r) = Integer.div_mod n 2; |
318 let val (q, r) = Integer.div_mod n 2; |
319 in mk_bit r $ bin_of q end; |
319 in mk_bit r $ bin_of q end; |
320 in bin_of n end; |
320 in bin_of n end; |
321 |
321 |
322 fun numeral_tr (*"_NumeralType"*) [Const (str, _)] = |
322 fun numeral_tr [Free (str, _)] = mk_bintype (the (Int.fromString str)) |
323 mk_bintype (the (Int.fromString str)) |
323 | numeral_tr ts = raise TERM ("numeral_tr", ts); |
324 | numeral_tr (*"_NumeralType"*) ts = raise TERM ("numeral_tr", ts); |
|
325 |
324 |
326 in [(@{syntax_const "_NumeralType"}, numeral_tr)] end; |
325 in [(@{syntax_const "_NumeralType"}, numeral_tr)] end; |
327 *} |
326 *} |
328 |
327 |
329 print_translation {* |
328 print_translation {* |
330 let |
329 let |
331 fun int_of [] = 0 |
330 fun int_of [] = 0 |
332 | int_of (b :: bs) = b + 2 * int_of bs; |
331 | int_of (b :: bs) = b + 2 * int_of bs; |
333 |
332 |
334 fun bin_of (Const (@{type_syntax num0}, _)) = [] |
333 fun bin_of (Const (@{type_syntax num0}, _)) = [] |
335 | bin_of (Const (@{type_syntax num1}, _)) = [1] |
334 | bin_of (Const (@{type_syntax num1}, _)) = [1] |
336 | bin_of (Const (@{type_syntax bit0}, _) $ bs) = 0 :: bin_of bs |
335 | bin_of (Const (@{type_syntax bit0}, _) $ bs) = 0 :: bin_of bs |
337 | bin_of (Const (@{type_syntax bit1}, _) $ bs) = 1 :: bin_of bs |
336 | bin_of (Const (@{type_syntax bit1}, _) $ bs) = 1 :: bin_of bs |
338 | bin_of t = raise TERM ("bin_of", [t]); |
337 | bin_of t = raise TERM ("bin_of", [t]); |
339 |
338 |
340 fun bit_tr' b [t] = |
339 fun bit_tr' b [t] = |
341 let |
340 let |
342 val rev_digs = b :: bin_of t handle TERM _ => raise Match |
341 val rev_digs = b :: bin_of t handle TERM _ => raise Match |
343 val i = int_of rev_digs; |
342 val i = int_of rev_digs; |
344 val num = string_of_int (abs i); |
343 val num = string_of_int (abs i); |
345 in |
344 in |
346 Syntax.const @{syntax_const "_NumeralType"} $ Syntax.free num |
345 Syntax.const @{syntax_const "_NumeralType"} $ Syntax.free num |
347 end |
346 end |
348 | bit_tr' b _ = raise Match; |
347 | bit_tr' b _ = raise Match; |
349 in [(@{type_syntax bit0}, bit_tr' 0), (@{type_syntax bit1}, bit_tr' 1)] end; |
348 in [(@{type_syntax bit0}, bit_tr' 0), (@{type_syntax bit1}, bit_tr' 1)] end; |
350 *} |
349 *} |
351 |
350 |
352 subsection {* Examples *} |
351 subsection {* Examples *} |
353 |
352 |