/pliant/language/type/number/int_sized.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   
 20  function select_low_bytes adr big_type small_type -> part 
 21    arg Address adr part ; arg Type big_type small_type 
 22    if processor_is_low_indian 
 23      part := adr 
 24    eif processor_is_high_indian 
 25      part := (adr translate big_type 1) translate small_tye -1 
 26    else 
 27      error error_id_runtime "processor "+processor_name+" is unknown indian" 
 28   
 29   
 30  function build_fixed_size_type name signed size 
 31    arg Str name ; arg CBool signed ; arg Int size 
 32    var Str ename := shunt signed "Int" "uInt" 
 33    var Ident reduced_type := cast name Ident 
 34    var Ident extended_type := cast ename Ident 
 35    var Ident cast_extension := cast "cast "+ename Ident 
 36    var Ident cast_reduction := cast "cast "+ename+('convert to string' size*8) Ident 
 37    var Str ctype 
 38    if size=1 
 39      ctype := "char" 
 40    eif size=2 
 41      ctype := "short" 
 42    else 
 43      ctype := "int" 
 44    if signed 
 45      ctype := "signed "+ctype 
 46    else 
 47      ctype := "unsigned "+ctype 
 48    runtime_compile reduced_type reduced_type  extended_type extended_type  signed signed  size  cast_extension cast_extension  cast_reduction cast_reduction ctype ctype 
 49   
 50      type reduced_type 
 51        field Byte b1 
 52        if s>=2 
 53          field Byte b2 
 54        if s>=4 
 55          field Byte b3 b4 
 56       
 57      function cast_extension i -> j 
 58        arg reduced_type i ; arg extended_type j 
 59        extension ; has_no_side_effect ; gcc_inline "$2 = *("+ctype+" *)@1;" 
 60        if reduced_type:size=extended_type:size 
 61          j := addressof:i map extended_type 
 62        eif signed 
 63          if ((addressof:i map extended_type) .and. 80h*100h^(reduced_type:size-1))=0 
 64            j := 0 
 65          else 
 66            j := -1 
 67          memory_copy addressof:i (select_low_bytes addressof:j extended_type reduced_type) reduced_type:size 
 68        else 
 69          j := 0 
 70          memory_copy addressof:i (select_low_bytes addressof:j extended_type reduced_type) reduced_type:size 
 71   
 72      function cast_reduction i -> j 
 73        arg extended_type i ; arg reduced_type j       
 74        reduction ; has_no_side_effect ; gcc_nocheck_inline "*("+ctype+" *)@2 = $1;" 
 75        if reduced_type:size<extended_type:size 
 76          if signed 
 77            check i>=-(256^s\2) and i<256^s\2 "The value is too large to fit in an "+reduced_type:name 
 78          else 
 79            check i<256^s "The value is too large to fit in an "+reduced_type:name 
 80          memory_copy (select_low_bytes addressof:i extended_type reduced_type) addressof:j reduced_type:size 
 81        else 
 82          addressof:j map extended_type := i   
 83   
 84      # function compare i j -> c 
 85      #   arg reduced_type i j ; arg Int c 
 86      #   c := compare (cast i extended_type) (cast j extended_type) 
 87   
 88      export reduced_type cast_extension cast_reduction # compare 
 89   
 90   
 91  build_fixed_size_type "Int8" true 1 
 92  build_fixed_size_type "Int16" true 2 
 93  build_fixed_size_type "Int32" true 4 
 94   
 95  build_fixed_size_type "uInt8" false 1 
 96  build_fixed_size_type "uInt16" false 2 
 97  build_fixed_size_type "uInt32" false 4 
 98  if Int:size=8 
 99    build_fixed_size_type "Int64" true 8 
 100    build_fixed_size_type "uInt64" false 8 
 101   
 102 
 
 103   
 104   
 105  if processor_name="i386" and pliant_debugging_level<2 
 106     
 107    function generate_extend_Int8_assembly instr gc 
 108      arg_rw Instruction instr ; arg_rw GeneratorContext gc 
 109      var Pointer:Instruction cur :> instr 
 110      var Link:Argument arg :> argument a_register 
 111      cur :> gc insert_after_instruction cur (instruction (the_function i386_movsx8 Int -> Int) instr:arg) 
 112      cur :> gc insert_after_instruction cur (instruction (the_function i386_mov Int Int) arg instr:1) 
 113      gc remove instr 
 114    (the_function 'cast Int' Int8 -> Int) set_generate_assembly (the_function generate_extend_Int8_assembly Instruction GeneratorContext) 
 115   
 116    function generate_extend_Int16_assembly instr gc 
 117      arg_rw Instruction instr ; arg_rw GeneratorContext gc 
 118      var Pointer:Instruction cur :> instr 
 119      var Link:Argument arg :> argument a_register 
 120      cur :> gc insert_after_instruction cur (instruction (the_function i386_movsx16 Int -> Int) instr:arg) 
 121      cur :> gc insert_after_instruction cur (instruction (the_function i386_mov Int Int) arg instr:1) 
 122      gc remove instr 
 123    (the_function 'cast Int' Int16 -> Int) set_generate_assembly (the_function generate_extend_Int16_assembly Instruction GeneratorContext) 
 124   
 125    function generate_extend_uInt8_assembly instr gc 
 126      arg_rw Instruction instr ; arg_rw GeneratorContext gc 
 127      var Pointer:Instruction cur :> instr 
 128      var Link:Argument arg :> argument a_register 
 129      cur :> gc insert_after_instruction cur (instruction (the_function i386_movzx8 Int -> Int) instr:arg) 
 130      cur :> gc insert_after_instruction cur (instruction (the_function i386_mov Int Int) arg instr:1) 
 131      gc remove instr 
 132    (the_function 'cast uInt' uInt8 -> uInt) set_generate_assembly (the_function generate_extend_uInt8_assembly Instruction GeneratorContext) 
 133   
 134    function generate_extend_uInt16_assembly instr gc 
 135      arg_rw Instruction instr ; arg_rw GeneratorContext gc 
 136      var Pointer:Instruction cur :> instr 
 137      var Link:Argument arg :> argument a_register 
 138      cur :> gc insert_after_instruction cur (instruction (the_function i386_movzx16 Int -> Int) instr:arg) 
 139      cur :> gc insert_after_instruction cur (instruction (the_function i386_mov Int Int) arg instr:1) 
 140      gc remove instr 
 141    (the_function 'cast uInt' uInt16 -> uInt) set_generate_assembly (the_function generate_extend_uInt16_assembly Instruction GeneratorContext) 
 142   
 143    function generate_reduce_Int8_assembly instr gc 
 144      arg_rw Instruction instr ; arg_rw GeneratorContext gc 
 145      var Pointer:Instruction cur :> instr 
 146      var Link:Argument arg :> argument a_register 
 147      cur :> gc insert_after_instruction cur (instruction (the_function i386_mov Int Int) instr:arg) 
 148      cur :> gc insert_after_instruction cur (instruction (the_function i386_mov8 Int -> Int) arg instr:1) 
 149      gc remove instr 
 150    (the_function 'cast Int8' Int -> Int8) set_generate_assembly (the_function generate_reduce_Int8_assembly Instruction GeneratorContext) 
 151    (the_function 'cast uInt8' uInt -> uInt8) set_generate_assembly (the_function generate_reduce_Int8_assembly Instruction GeneratorContext) 
 152   
 153    function generate_reduce_Int16_assembly instr gc 
 154      arg_rw Instruction instr ; arg_rw GeneratorContext gc 
 155      var Pointer:Instruction cur :> instr 
 156      var Link:Argument arg :> argument a_register 
 157      cur :> gc insert_after_instruction cur (instruction (the_function i386_mov Int Int) instr:arg) 
 158      cur :> gc insert_after_instruction cur (instruction (the_function i386_mov16 Int -> Int) arg instr:1) 
 159      gc remove instr 
 160    (the_function 'cast Int16' Int -> Int16) set_generate_assembly (the_function generate_reduce_Int16_assembly Instruction GeneratorContext) 
 161    (the_function 'cast uInt16' uInt -> uInt16) set_generate_assembly (the_function generate_reduce_Int16_assembly Instruction GeneratorContext)