Patch title: Release 92 bulk changes
Abstract:
File: /language/type/text/istr.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-8 ] ; link "Unicode" "http://www.unicode.org/" ; [ strings]

# scope "/pliant/language/" "/pliant/install/"
module "/pliant/install/ring2.pli"
submodule "str32.pli"
module "/pliant/util/encoding/utf8.pli"

type iStr
  field Address buffer
  field Int size
  field Str utf8


function build s
  arg_w iStr s
  s buffer := null
  s size := 0

function destroy s
  arg_w iStr s
  memory_free s:buffer

function copy s d
  arg iStr s ; arg_w iStr d
  memory_free d:buffer
  var Int l := s size
  d buffer := memory_allocate l addressof:d
  d size := l
  memory_copy s:buffer d:buffer l


function 'cast iStr' s32 -> s
  arg Str32 s32 ; arg iStr s
  reduction
  var Int size := 0
  for (var Int i) 0 s32:len-1
    var Int c := s32:i:number
    if c<2^7
      size += 1
    eif c<2^11
      size += 2
    eif c<2^16
      size += 3
    eif c<2^21
      size += 4
  memory_free s:buffer
  s buffer := memory_allocate size addressof:s
  s size := size
  var Address ptr := s buffer
  for (var Int i) 0 s32:len-1
    var Int c := s32:i:number
    if c<2^7
      ptr map uInt8 := c ; ptr := ptr translate Byte 1
    eif c<2^11
      ptr map uInt8 := 0C0h+c\2^6 ; ptr := ptr translate Byte 1
      ptr map uInt8 := 080h+(c .and. 3Fh) ; ptr := ptr translate Byte 1
    eif c<2^16
      ptr map uInt8 := 0E0h+c\2^12 ; ptr := ptr translate Byte 1
      ptr map uInt8 := 080h+(c\2^6 .and. 3Fh) ; ptr := ptr translate Byte 1
      ptr map uInt8 := 080h+(c .and. 3Fh) ; ptr := ptr translate Byte 1
    eif c<2^21
      ptr map uInt8 := 0F0h+c\2^18 ; ptr := ptr translate Byte 1
      ptr map uInt8 := 080h+(c\2^12 .and. 3Fh) ; ptr := ptr translate Byte 1
      ptr map uInt8 := 080h+(c\2^6 .and. 3Fh) ; ptr := ptr translate Byte 1
      ptr map uInt8 := 080h+(c .and. 3Fh) ; ptr := ptr translate Byte 1
  s utf8 := utf8_encode s32

function utf8_length c -> l
  arg Int c l
  if c<80h
    l := 1
  eif c<0C0h
    l := undefined
  eif c<0E0h
    l := 2
  eif c<0F0h
    l := 3
  eif c<0F8h
    l := 4
  else
    l := undefined

function 'cast Str32' s -> s32
  arg iStr s ; arg Str32 s32
  extension
  var Int count := 0
  var Address src := s buffer ; var Int remain := s size
  while remain>0
    var Int l := utf8_length (src map uInt8)
    if l<=remain
      count += 1
    src := src translate uInt8 l ; remain -= l
  s32 set (memory_allocate count*Char32:size addressof:s32) count true
  var Address src := s buffer ; var Int remain := s size
  var Address dest := s32 characters
  while remain>0
    var Int c := src map uInt8
    var Int l := utf8_length c
    if l=1
      c := c .and. 7Fh
    eif l<=remain
      c := c .and. 07Fh\2^l
      for (var Int i) 1 l-1
        c := c*2^6+(((src translate uInt8 i) map uInt8) .and. 3Fh)
    src := src translate uInt8 l ; remain -= l
    dest map Int32 := c ; dest := dest translate Int32 1
  check dest=(s32:characters translate Char32 count)
  s32 := utf8_decode s:utf8

function 'cast Status' s -> status
  arg iStr s ; arg Status status
  explicit
  var Address ptr := s buffer ; var Int remain := s size
  while remain>0
    var Int l := utf8_length (ptr map uInt8)
    if l=undefined or l>remain
      return failure
    for (var Int i) 1 l-1
      if (((ptr translate uInt8 i) map uInt8) .and. 0C0h)<>80h
        return failure
    ptr := ptr translate uInt8 l ; remain -= l
  status := success
  status := utf8_check s:utf8


function compare s1 s2 -> c
  arg iStr s1 s2 ; arg Int c
  c := compare (addressof:s1 map Str) (addressof:s2 map Str)
  c := compare s1:utf8 s2:utf8

function '+' s1 s2 -> s
  arg iStr s1 s2 s
  (addressof:s map Str) := (addressof:s1 map Str) + (addressof:s2 map Str)
  s utf8 := s1:utf8 + s2:utf8


export iStr
export 'cast iStr' 'cast Str32' 'cast Status'
export compare '+'


if false

  function random maxi -> r
    arg uInt maxi r
    memory_random addressof:r uInt:size
    r := r%maxi
  
  function debug
    for (var Int lap) 1 1000
      var Str32 original := ""
      var Int l := random 300
      for (var Int i) 0 l
        original := original+character32:(random 2^(random 20))
      var iStr encoded := original
      if encoded=failure
        console "iStr status oops" eol
        return
      var Str32 decoded := encoded
      if decoded<>original
        console "iStr encode/decode oops" eol
        return
    console "iStr ok" eol
    
  debug