Patch title: Release 95 bulk changes
Abstract:
File: /pliant/language/type/text/str32.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.

abstract
  [UTF-32 ] ; link "Unicode" "http://www.unicode.org/" ; [ strings]

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

constant undefined_character "?"


type Char32
  field Int32 num

function character32 i -> c
  arg Int i ; arg Char32 c
  c num := i

method c number -> i
  arg Char32 c ; arg Int i
  i := c num


type Str32
  field Address characters
  field Int count


method s set buf len allocated
  arg_w Str32 s ; arg Address buf ; arg Int len ; arg CBool allocated
  if s:count>0
    memory_free s:characters
  s characters := buf
  s count := shunt allocated len -len
  
method s len -> l
  arg Str32 s ; arg Int l
  l := abs s:count

method s '' i -> c
  arg Str32 s ; arg Int i ; arg_C Char32 c
  check i>=0 and i<s:len
  c :> s:characters map Char32 i
# ((the_function '' Str32 Int -> Char32) arg 2) maps := 1

method s '' i j -> sub
  arg Str32 s ; arg Int i j ; arg Str32 sub
  check i>=0 and j>=0
  var Int l := max (min j s:len-i) 0
  sub set (s:characters translate Char32 i) l false
((the_function '' Str32 Int Int -> Str32) arg 3) maps := 1


function build s
  arg_w Str32 s
  s characters := null
  s count := 0

function destroy s
  arg_w Str32 s
  if s:count>0
    memory_free s:characters

function copy s d
  arg Str32 s ; arg_w Str32 d
  var Int l := s len
  var Address c := memory_allocate l*Char32:size addressof:d
  memory_copy s:characters c l*Char32:size
  d set c l true


function '+' s1 s2 -> s
  arg Str32 s1 s2 s
  var Int l := s1:len+s2:len
  s set (memory_allocate l*Char32:size addressof:s) l true
  memory_copy s1:characters s:characters s1:len*Char32:size
  memory_copy s2:characters (s:characters translate Char32 s1:len) s2:len*Char32:size


function compare s1 s2 -> c
  arg Str32 s1 s2 ; arg Int c
  var Int l := min s1:len s2:len
  var Address p1 := s1 characters ; var Address stop := p1 translate Int32 l
  var Address p2 := s2 characters
  while p1<>stop
    if (p1 map Int32)<>(p2 map Int32)
      return (compare (p1 map Int32) (p2 map Int32))
    p1 := p1 translate Int32 1 ; p2 := p2 translate Int32 1
  if s1:len>s2:len
    c := compare_superior
  eif s1:len<s2:len
    c := compare_inferior
  else
    c := compare_equal


export Char32
export character32 '. number'
export Str32 '. set'
export '. characters' '. len' ''
export compare '+'


function 'cast Str32' c -> s
  arg Char32 c ; arg Str32 s
  extension
  s set (memory_allocate Char32:size addressof:s) 1 true
  s:characters map Char32 := c


function 'cast Str32' s -> s32
  arg Str s ; arg Str32 s32
  extension
  if default_charset_is_utf8
    module "/pliant/util/encoding/utf8.pli"
    s32 := utf8_decode s
  else
    var Int l := s len
    s32 set (memory_allocate l*Char32:size addressof:s32) l true
    var Address src := s characters ; var Address stop := src translate uInt8 l
    var Address dest := s32 characters
    while src<>stop
      dest map Int32 := src map uInt8
      src := src translate uInt8 1 ; dest := dest translate Int32 1


function 'cast Str' s32 -> s
  arg Str32 s32 ; arg Str s
  reduction
  if default_charset_is_utf8
    module "/pliant/util/encoding/utf8.pli"
    s := utf8_encode s32
  else
    var Int l := s32 len
    s set (memory_allocate l addressof:s) l true
    var Address src := s32 characters
    var Address dest := s characters ; var Address stop := dest translate uInt8 l
    while dest<>stop
      var Int c := src map Int32
      if c>=100h
        c := undefined_character number
      dest map uInt8 := c
      src := src translate Int32 1 ; dest := dest translate uInt8 1


method s search pattern default -> index
  arg Str32 s pattern ; arg Int default index
  if true
    var Int ls := s len ; var Int lp := pattern len
    check lp<>0
    if ls>=lp
      var Address cur := s characters
      var Address stop := cur translate Char32 ls-lp+1
      var Address wished := pattern characters ; var Int size := lp*Char32:size
      var Int ch := wished map Int32
      while cur<>stop
        if (cur map Int32)=ch
          if not (memory_different cur size wished size)
            return ((cast cur Int) .-. (cast s:characters Int))\Char32:size
        cur := cur translate Char32
    index := default
  else
    check pattern:len>0
    for index 0 s:len-pattern:len
      if (s index pattern:len)=pattern
        return
    index := default


export 'cast Str32' 'cast Str' '. search'