/pliant/language/type/text/str32.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  abstract 
 17    [UTF-32 ] ; link "Unicode" "http://www.unicode.org/" ; [ strings] 
 18   
 19  # scope "/pliant/language/" "/pliant/install/" 
 20  module "/pliant/install/ring2.pli" 
 21  ring_module 
 22   
 23  constant undefined_character "?" 
 24   
 25   
 26  type Char32 
 27    field Int32 num 
 28   
 29  function character32 i -> c 
 30    arg Int i ; arg Char32 c 
 31    num := i 
 32   
 33  method c number -> i 
 34    arg Char32 c ; arg Int i 
 35    := num 
 36   
 37   
 38  type Str32 
 39    field Address characters 
 40    field Int count 
 41   
 42   
 43  method s set buf len allocated 
 44    arg_w Str32 s ; arg Address buf ; arg Int len ; arg CBool allocated 
 45    if s:count>0 
 46      memory_free s:characters 
 47    characters := buf 
 48    count := shunt allocated len -len 
 49     
 50  method s len -> l 
 51    arg Str32 s ; arg Int l 
 52    := abs s:count 
 53   
 54  method s '' i -> c 
 55    arg Str32 s ; arg Int i ; arg_C Char32 c 
 56    check i>=and i<s:len 
 57    :> s:characters map Char32 i 
 58  # ((the_function '' Str32 Int -> Char32) arg 2) maps := 1 
 59   
 60  method s '' i j -> sub 
 61    arg Str32 s ; arg Int j ; arg Str32 sub 
 62    check i>=and j>=0 
 63    var Int := max (min s:len-i) 0 
 64    sub set (s:characters translate Char32 i) false 
 65  ((the_function '' Str32 Int Int -> Str32) arg 3) maps := 1 
 66   
 67   
 68  function build s 
 69    arg_w Str32 s 
 70    characters := null 
 71    count := 0 
 72   
 73  function destroy s 
 74    arg_w Str32 s 
 75    if s:count>0 
 76      memory_free s:characters 
 77   
 78  function copy s d 
 79    arg Str32 s ; arg_w Str32 d 
 80    var Int := len 
 81    var Address := memory_allocate l*Char32:size addressof:d 
 82    memory_copy s:characters l*Char32:size 
 83    set true 
 84   
 85   
 86  function '+' s1 s2 -> s 
 87    arg Str32 s1 s2 s 
 88    var Int := s1:len+s2:len 
 89    set (memory_allocate l*Char32:size addressof:s) true 
 90    memory_copy s1:characters s:characters s1:len*Char32:size 
 91    memory_copy s2:characters (s:characters translate Char32 s1:len) s2:len*Char32:size 
 92   
 93   
 94  function compare s1 s2 -> c 
 95    arg Str32 s1 s2 ; arg Int c 
 96    var Int := min s1:len s2:len 
 97    var Address p1 := s1 characters ; var Address stop := p1 translate Int32 l 
 98    var Address p2 := s2 characters 
 99    while p1<>stop 
 100      if (p1 map Int32)<>(p2 map Int32) 
 101        return (compare (p1 map Int32) (p2 map Int32)) 
 102      p1 := p1 translate Int32 1 ; p2 := p2 translate Int32 1 
 103    if s1:len>s2:len 
 104      := compare_superior 
 105    eif s1:len<s2:len 
 106      := compare_inferior 
 107    else 
 108      := compare_equal 
 109   
 110   
 111  export Char32 
 112  export character32 '. number' 
 113  export Str32 '. set' 
 114  export '. characters' '. len' '' 
 115  export compare '+' 
 116   
 117   
 118  function 'cast Str32' c -> s 
 119    arg Char32 c ; arg Str32 s 
 120    extension 
 121    set (memory_allocate Char32:size addressof:s) true 
 122    s:characters map Char32 := c 
 123   
 124   
 125  function 'cast Str32' s -> s32 
 126    arg Str s ; arg Str32 s32 
 127    extension 
 128    if default_charset_is_utf8 
 129      module "/pliant/util/encoding/utf8.pli" 
 130      s32 := utf8_decode s 
 131    else 
 132      var Int l := s len 
 133      s32 set (memory_allocate l*Char32:size addressof:s32) l true 
 134      var Address src := s characters ; var Address stop := src translate uInt8 l 
 135      var Address dest := s32 characters 
 136      while src<>stop 
 137        dest map Int32 := src map uInt8 
 138        src := src translate uInt8 1 ; dest := dest translate Int32 1 
 139   
 140   
 141  function 'cast Str' s32 -> s 
 142    arg Str32 s32 ; arg Str s 
 143    reduction 
 144    if default_charset_is_utf8 
 145      module "/pliant/util/encoding/utf8.pli" 
 146      := utf8_encode s32 
 147    else 
 148      var Int l := s32 len 
 149      s set (memory_allocate l addressof:s) l true 
 150      var Address src := s32 characters 
 151      var Address dest := s characters ; var Address stop := dest translate uInt8 l 
 152      while dest<>stop 
 153        var Int c := src map Int32 
 154        if c>=100h 
 155          c := undefined_character number 
 156        dest map uInt8 := c 
 157        src := src translate Int32 1 ; dest := dest translate uInt8 1 
 158   
 159   
 160  method s search pattern default -> index 
 161    arg Str32 pattern ; arg Int default index 
 162    if true 
 163      var Int ls := len ; var Int lp := pattern len 
 164      check lp<>0 
 165      if ls>=lp 
 166        var Address cur := characters 
 167        var Address stop := cur translate Char32 ls-lp+1 
 168        var Address wished := pattern characters ; var Int size := lp*Char32:size 
 169        var Int ch := wished map Int32 
 170        while cur<>stop 
 171          if (cur map Int32)=ch 
 172            if not (memory_different cur size wished size) 
 173              return ((cast cur Int) .-. (cast s:characters Int))\Char32:size 
 174          cur := cur translate Char32 
 175      index := default 
 176    else 
 177      check pattern:len>0 
 178      for index 0 s:len-pattern:len 
 179        if (s index pattern:len)=pattern 
 180          return 
 181      index := default 
 182   
 183   
 184  export 'cast Str32' 'cast Str' '. search'