Patch title: Release 94 bulk changes
Abstract:
File: /pliant/language/stream/stream.pli
Key:
    Removed line
    Added line
   
# Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx
#
# This program is free software; you can redistribute it and
# modify it under the terms of the GNU General Public Licens
# as published by the Free Software Foundation.
#
# This program is distributed in the hope that it will be us
# but WITHOUT ANY WARRANTY; without even the implied warrant
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See 
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public 
# version 2 along with this program; if not, write to the Fr
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 


# Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx
#
# This program is free software; you can redistribute it and
# modify it under the terms of the GNU General Public Licens
# as published by the Free Software Foundation.
#
# This program is distributed in the hope that it will be us
# but WITHOUT ANY WARRANTY; without even the implied warrant
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See 
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public 
# version 2 along with this program; if not, write to the Fr
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 


constant has_unreadline true
constant has_rewind true


#-----------------------------------------------------------
# Stream 



#-----------------------------------------------------------
# Stream 



if has_rewind


  type StreamBuffer
    field Address start stop

  type StreamMark
    field Pointer:StreamBuffer buffer
    field Int offset   


type Stream
  field Address read_cur read_stop
  field Address write_cur write_stop


  field Int line_number
  field Int line_limit
type Stream
  field Address read_cur read_stop
  field Address write_cur write_stop


  field Int line_number
  field Int line_limit
  field Str next_line
  if has_unreadline
    field Str next_line
  
  if has_rewind
    field List:StreamBuffer rewind_buffers
    field Pointer:StreamBuffer rewind_current
    field Address rewind_stop # backup of read_stop
    field Array:StreamMark rewind_stack ; field Int rewind_count
    field Int rewind_size rewind_limit



(addressof:Stream map Type) flags := Stream:flags .or. type_



(addressof:Stream map Type) flags := Stream:flags .or. type_



constant crashed              01000000h
constant unflushed            02000000h
constant next_line_available  04000000h
constant crashed                01000000h
constant unflushed              02000000h
if has_unreadline
  constant next_line_available  04000000h
if has_rewind
  constant rewind_is_active    08000000h






method s error msg
  arg_rw Stream s ; arg Str msg
  s flags := s:flags .or. crashed
  s read_cur := s read_stop
  s write_cur := s write_stop
  if (s:flags .and. safe)=0
    error error_id_io msg+" ("+s:name+")"


if has_rewind

  method s rewind_read_required -> required
    arg_rw Stream s ; arg CBool required
    if (s:flags .and. rewind_is_active)=0
      return true
    var Pointer:StreamBuffer b1 :> s rewind_current
    if exists:b1
      var Pointer:StreamBuffer b2 :> s:rewind_buffers next s:rewind_current
      s rewind_current :> b2
      if exists:b2
        s read_cur := b2 start
        s read_stop := b2 stop
      else
        s read_cur := s read_buf
        s read_stop := s rewind_stop
      if s:rewind_count=0
        memory_free b1:start
        s rewind_size -= (cast b1:stop Int) .-. (cast b1:start Int)
        s:rewind_buffers remove b1
        if not exists:b2
          s flags := s:flags .and. .not. (cast rewind_is_active Int)
      required := s:read_cur=s:read_stop      
    else
      var Int size := (cast s:read_stop Int) .-. (cast s:read_buf Int)
      var Int skip := size
      for (var Int i) 0 s:rewind_count-1
        var Pointer:StreamMark m :> s:rewind_stack i
        skip := shunt (exists m:buffer) 0 (min skip m:offset)
      size -= skip
      while s:rewind_size+size>s:rewind_limit and s:rewind_size>0
        var Pointer:StreamBuffer b :> s:rewind_buffers first
        for (var Int i) 0 s:rewind_count-1
          var Pointer:StreamMark m :> s:rewind_stack i
          if (addressof m:buffer)=addressof:b
            m offset := undefined
        memory_free b:start
        s rewind_size -= (cast b:stop Int) .-. (cast b:start Int)
        s:rewind_buffers remove b
      if size>0
        s rewind_buffers += var StreamBuffer empty_buffer
        var Pointer:StreamBuffer b :> s:rewind_buffers last
        b start := memory_allocate size addressof:s
        memory_copy (s:read_buf translate Byte skip) b:start size
        b stop := b:start translate Byte size
        s rewind_size += size
        for (var Int i) 0 s:rewind_count-1
          var Pointer:StreamMark m :> s:rewind_stack i
          if not (exists m:buffer)
            m buffer :> b
            m offset -= skip
      else
        for (var Int i) 0 s:rewind_count-1
          var Pointer:StreamMark m :> s:rewind_stack i
          if not (exists m:buffer)
            m offset := 0
      required := true

  method s rewind_open
    arg_rw Stream s
    s flags := s:flags .or. rewind_is_active
    var Int count := s rewind_count
    s rewind_count := count+1
    if count>=s:rewind_stack:size
      s:rewind_stack size := count+1
    var Pointer:StreamMark m :> s:rewind_stack count
    m buffer :> s rewind_current
    var Address start
    if (exists s:rewind_current)
      start := s:rewind_current start
    else
      start := s read_buf
    m offset := (cast s:read_cur Int) .-. (cast start Int)

  method s rewind
    arg_rw Stream s
    check s:rewind_count>0
    var Pointer:StreamMark m :> s:rewind_stack s:rewind_count-1
    if m:offset=undefined
      s error "rewind capacity overflow"
      return
    var Pointer:StreamBuffer b :> m buffer
    if not (exists s:rewind_current)
      s rewind_stop := s read_stop
    s rewind_current :> b
    if exists:b
      s read_cur := b:start translate Byte m:offset
      s read_stop := b stop
    else
      s read_cur := s:read_buf translate Byte m:offset
    
  method s rewind_close
    arg_rw Stream s
    var Int count := s rewind_count
    check count>0
    count -= 1
    s rewind_count := count
    if count=0
      while { var Pointer:StreamBuffer b :> s:rewind_buffers first ; exists:b and addressof:b<>(addressof s:rewind_current) }
        memory_free b:start
        s rewind_size -= (cast b:stop Int) .-. (cast b:start Int)
        s:rewind_buffers remove b
      if not exists:b
        s flags := s:flags .and. .not. (cast rewind_is_active Int)


method s reset
  arg_rw Stream s
  s read_cur := null ; s read_stop := null
  s write_cur := null ; s write_stop := null
  memory_free s:read_buf ; s read_buf := null
  memory_free s:write_buf ; s write_buf := null
  s flags := s:flags .and. crashed
  s handle := undefined
  s driver :> null map StreamDriver
  s line_number := 0
  s line_limit := 2^16
method s reset
  arg_rw Stream s
  s read_cur := null ; s read_stop := null
  s write_cur := null ; s write_stop := null
  memory_free s:read_buf ; s read_buf := null
  memory_free s:write_buf ; s write_buf := null
  s flags := s:flags .and. crashed
  s handle := undefined
  s driver :> null map StreamDriver
  s line_number := 0
  s line_limit := 2^16
  if has_rewind
    each b s:rewind_buffers
      memory_free b:start
    s rewind_buffers := var List:StreamBuffer empty_buffers_list
    s rewind_current :> null map StreamBuffer
    s:rewind_stack size := 0 ; s rewind_count := 0
    s rewind_size := 0
    s rewind_limit := 2^24




method s error msg
  arg_rw Stream s ; arg Str msg
  s flags := s:flags .or. crashed
  s read_cur := s read_stop
  s write_cur := s write_stop
  if (s:flags .and. safe)=0
    error error_id_io msg+" ("+s:name+")"


method s write_all_data address size
  arg_rw Stream s ; arg Address address ; arg Int size
  var Address adr := address
  var Int remain := size
  while remain>0
    var Int written := s:driver write adr remain remain
    check written>=0
    if written<=0
      s error "Failed to write to stream"
      return
    else
      s flags := s:flags .or. unflushed
      adr := adr translate Byte written
      remain := remain-written


method s raw_read address size
  arg_rw Stream s ; arg Address address ; arg Int size
  check size>=0
  if (s:read_cur translate Byte size)<=s:read_stop
    memory_copy s:read_cur address size
    s read_cur := s:read_cur translate Byte size
  else
    if (s:flags .and. in)=0
      s error "Attempted to read from an "+(shunt s:is_open 
    if (s:flags .and. noautopost)=0 and (s:write_cur<>s:writ
      s flush async
    var Address adr := address
    var Int remain := size
    while remain>0
      if s:is_crashed
        memory_clear adr remain
        return
      eif s:read_cur<>s:read_stop
        var Int step := min (cast s:read_stop Int).-.(cast s
        memory_copy s:read_cur adr step
        s read_cur := s:read_cur translate Byte step ; adr :
method s write_all_data address size
  arg_rw Stream s ; arg Address address ; arg Int size
  var Address adr := address
  var Int remain := size
  while remain>0
    var Int written := s:driver write adr remain remain
    check written>=0
    if written<=0
      s error "Failed to write to stream"
      return
    else
      s flags := s:flags .or. unflushed
      adr := adr translate Byte written
      remain := remain-written


method s raw_read address size
  arg_rw Stream s ; arg Address address ; arg Int size
  check size>=0
  if (s:read_cur translate Byte size)<=s:read_stop
    memory_copy s:read_cur address size
    s read_cur := s:read_cur translate Byte size
  else
    if (s:flags .and. in)=0
      s error "Attempted to read from an "+(shunt s:is_open 
    if (s:flags .and. noautopost)=0 and (s:write_cur<>s:writ
      s flush async
    var Address adr := address
    var Int remain := size
    while remain>0
      if s:is_crashed
        memory_clear adr remain
        return
      eif s:read_cur<>s:read_stop
        var Int step := min (cast s:read_stop Int).-.(cast s
        memory_copy s:read_cur adr step
        s read_cur := s:read_cur translate Byte step ; adr :
      eif remain<s:read_buf_size\2
        var Int red := s:driver read s:read_buf remain s:rea
        check red>=0
        if red<=0
          s error "Failed to read from stream"
        s read_cur := s read_buf ; s read_stop := s:read_buf
      eif remain<s:read_buf_size\2 or has_rewind and (s:flags .and. rewind_is_active)<>0
        if not has_rewind or s:rewind_read_required
          var Int red := s:driver read s:read_buf remain s:read_buf_size
          check red>=0
          if red<=0
            s error "Failed to read from stream"
          s read_cur := s read_buf ; s read_stop := s:read_buf translate Byte red
      else
        var Int red := s:driver read adr remain remain
        check red>=0
        if red<=0
          s error "Failed to read from stream"
        adr := adr translate Byte red ; remain := remain-red



method s open name options flags fs support -> status
  arg_rw Stream s ; arg Str name options ; arg Int flags ; o
  s close
  s name := name
  s flags := flags .or. (shunt (flags .and. append)=append o
      else
        var Int red := s:driver read adr remain remain
        check red>=0
        if red<=0
          s error "Failed to read from stream"
        adr := adr translate Byte red ; remain := remain-red



method s open name options flags fs support -> status
  arg_rw Stream s ; arg Str name options ; arg Int flags ; o
  s close
  s name := name
  s flags := flags .or. (shunt (flags .and. append)=append o
  var Int cs := shunt (flags .and. nocache)<>0 0 (flags .and
  var Int cs := shunt (flags .and. nocache)<>0 0 (flags .and. linecache)<>0 2^8 (flags .and. bigcache)<>0 2^16 2^12
  s read_buf_size := cs
  s write_buf_size := cs
  status := fs open name options s:flags s support
  if status=failure and (s:flags .and. out+mkdir)=out+mkdir
    if not (name:len>0 and name:0="[dq]" and (name parse (va
      base := name ; opt := ""    
    var Int i := base:len
    while { i := (base 0 i) search_last "/" 0 ; i<>0 and (fs
      void
    while { i := i+1 ; i := ((base i base:len) search "/" -i
      fs configure string:(base 0 i+1) opt+(shunt opt:len<>0
    status := fs open name options s:flags s support
    if status=failure
      i := 0
      while { i := i+1 ; i := ((base i base:len) search "/" 
        fs configure (base 0 i+1) opt+(shunt opt:len<>0 and 
      status := fs open name options s:flags s support
  if status=success
    check (addressof s:driver)<>null
    if (s:flags .and. in)<>0
      s read_buf := memory_allocate s:read_buf_size addresso
      s read_cur := s read_buf
      s read_stop := s read_buf
    else
      s read_buf_size := 0
    if (s:flags .and. out)<>0
      s write_buf := memory_allocate s:write_buf_size addres
      s write_cur := s write_buf
      s write_stop := s:write_buf translate Byte s:write_buf
    else
      s write_buf_size := 0
  else
    check (addressof s:driver)=null
    s flags := crashed+(flags .and. safe)
(the_function '. open' Stream Str Str Int FileSystem Stream 


method s atend -> ae
  arg_rw Stream s ; arg CBool ae
  if s:read_cur<>s:read_stop
    return false
  if (s:flags .and. in)=0
    s error "Attempted to test read end on an "+(shunt s:is_
  if (s:flags .and. crashed)<>0
    return true
  s read_buf_size := cs
  s write_buf_size := cs
  status := fs open name options s:flags s support
  if status=failure and (s:flags .and. out+mkdir)=out+mkdir
    if not (name:len>0 and name:0="[dq]" and (name parse (va
      base := name ; opt := ""    
    var Int i := base:len
    while { i := (base 0 i) search_last "/" 0 ; i<>0 and (fs
      void
    while { i := i+1 ; i := ((base i base:len) search "/" -i
      fs configure string:(base 0 i+1) opt+(shunt opt:len<>0
    status := fs open name options s:flags s support
    if status=failure
      i := 0
      while { i := i+1 ; i := ((base i base:len) search "/" 
        fs configure (base 0 i+1) opt+(shunt opt:len<>0 and 
      status := fs open name options s:flags s support
  if status=success
    check (addressof s:driver)<>null
    if (s:flags .and. in)<>0
      s read_buf := memory_allocate s:read_buf_size addresso
      s read_cur := s read_buf
      s read_stop := s read_buf
    else
      s read_buf_size := 0
    if (s:flags .and. out)<>0
      s write_buf := memory_allocate s:write_buf_size addres
      s write_cur := s write_buf
      s write_stop := s:write_buf translate Byte s:write_buf
    else
      s write_buf_size := 0
  else
    check (addressof s:driver)=null
    s flags := crashed+(flags .and. safe)
(the_function '. open' Stream Str Str Int FileSystem Stream 


method s atend -> ae
  arg_rw Stream s ; arg CBool ae
  if s:read_cur<>s:read_stop
    return false
  if (s:flags .and. in)=0
    s error "Attempted to test read end on an "+(shunt s:is_
  if (s:flags .and. crashed)<>0
    return true
  eif (s:flags .and. next_line_available)<>0
  eif has_unreadline and (s:flags .and. next_line_available)<>0
    return false
  else
    if (s:flags .and. noautopost)=0 and (s:write_cur<>s:writ
      s flush async
      if (s:flags .and. crashed)<>0
        return true
    return false
  else
    if (s:flags .and. noautopost)=0 and (s:write_cur<>s:writ
      s flush async
      if (s:flags .and. crashed)<>0
        return true
    var Int red := s:driver read s:read_buf 1 s:read_buf_siz
    check red>=0
    s read_cur := s read_buf
    s read_stop := s:read_buf translate Byte red
    return red<=0
    if not has_rewind or s:rewind_read_required
      var Int red := s:driver read s:read_buf 1 s:read_buf_size
      check red>=0
      s read_cur := s read_buf
      s read_stop := s:read_buf translate Byte red
      return red<=0
    else
      return false



method s readline -> l
  arg_rw Stream s ; arg Str l



method s readline -> l
  arg_rw Stream s ; arg Str l
  if (s:flags .and. next_line_available)<>0
  if has_unreadline and (s:flags .and. next_line_available)<>0
    l := s next_line
    s next_line := ""
    s flags := s:flags-next_line_available
    return
  l := ""
  if s:atend
    return
  s line_number := s:line_number+1
  while true
    if s:atend
      return
    var Int mode := s:flags .and. cr+lf
    var Address eol := memory_search s:read_cur (cast s:read
    if  mode=0
      var Address eol_cr := memory_search s:read_cur (cast s
      var Address eol_lf := eol
      eol :=  shunt eol_cr<>null and (eol_lf=null or (cast e
    var Int extra := (cast (shunt eol<>null eol s:read_stop)
    check extra>=0
    if l:len+extra>s:line_limit
      s error "too long line"
      l := ""
      return
    l resize l:len+extra
    memory_copy s:read_cur (l:characters translate Char l:le
    if eol<>null
      s read_cur := eol translate Char 1
      if mode=cr+lf and l:len>0 and (l l:len-1)="[cr]"
        l resize l:len-1
      if mode=0 
        if eol=eol_cr and not s:atend and (s:read_cur map Ch
          s read_cur := s:read_cur translate Char 1
          mode := cr+lf
        eif eol=eol_lf
          mode := lf
        else
          check eol=eol_cr
          mode := cr
        if (s:flags .and. anyeol)=0
          s:flags := s:flags .or. mode
      return
    else
      s read_cur := s read_stop


    l := s next_line
    s next_line := ""
    s flags := s:flags-next_line_available
    return
  l := ""
  if s:atend
    return
  s line_number := s:line_number+1
  while true
    if s:atend
      return
    var Int mode := s:flags .and. cr+lf
    var Address eol := memory_search s:read_cur (cast s:read
    if  mode=0
      var Address eol_cr := memory_search s:read_cur (cast s
      var Address eol_lf := eol
      eol :=  shunt eol_cr<>null and (eol_lf=null or (cast e
    var Int extra := (cast (shunt eol<>null eol s:read_stop)
    check extra>=0
    if l:len+extra>s:line_limit
      s error "too long line"
      l := ""
      return
    l resize l:len+extra
    memory_copy s:read_cur (l:characters translate Char l:le
    if eol<>null
      s read_cur := eol translate Char 1
      if mode=cr+lf and l:len>0 and (l l:len-1)="[cr]"
        l resize l:len-1
      if mode=0 
        if eol=eol_cr and not s:atend and (s:read_cur map Ch
          s read_cur := s:read_cur translate Char 1
          mode := cr+lf
        eif eol=eol_lf
          mode := lf
        else
          check eol=eol_cr
          mode := cr
        if (s:flags .and. anyeol)=0
          s:flags := s:flags .or. mode
      return
    else
      s read_cur := s read_stop


method s unreadline l
  arg_rw Stream s ; arg Str l
  s next_line := l
  s flags := s:flags .or. next_line_available
if has_unreadline
  method s unreadline l
    arg_rw Stream s ; arg Str l
    s next_line := l
    s flags := s:flags .or. next_line_available



export '. open' '. close' '. raw_read' '. raw_write' '. flus



export '. open' '. close' '. raw_read' '. raw_write' '. flus
export '. writechars' '. readline' '. unreadline' '. eol' '.
export '. writechars' '. readline' '. eol' '. writeline'
if has_unreadline
  export '. unreadline'
export '. atend' '. read_available' '. error'
export raw_copy



alias '. stream_handle' '. handle'
alias '. stream_flags' '. flags'
alias '. stream_driver' '. driver'
alias '. stream_read_buf' '. read_buf'
alias '. stream_read_buf_size' '. read_buf_size'
alias '. stream_read_cur' '. read_cur'
alias '. stream_read_stop' '. read_stop'
alias '. stream_write_buf' '. write_buf'
alias '. stream_write_buf_size' '. write_buf_size'
alias '. stream_write_cur' '. write_cur'
alias '. stream_write_stop' '. write_stop'
export '. stream_handle' '. stream_flags' '. stream_driver'
export '. stream_read_buf' '. stream_read_buf_size' '. strea
export '. stream_write_buf' '. stream_write_buf_size' '. str
export '. atend' '. read_available' '. error'
export raw_copy



alias '. stream_handle' '. handle'
alias '. stream_flags' '. flags'
alias '. stream_driver' '. driver'
alias '. stream_read_buf' '. read_buf'
alias '. stream_read_buf_size' '. read_buf_size'
alias '. stream_read_cur' '. read_cur'
alias '. stream_read_stop' '. read_stop'
alias '. stream_write_buf' '. write_buf'
alias '. stream_write_buf_size' '. write_buf_size'
alias '. stream_write_cur' '. write_cur'
alias '. stream_write_stop' '. write_stop'
export '. stream_handle' '. stream_flags' '. stream_driver'
export '. stream_read_buf' '. stream_read_buf_size' '. strea
export '. stream_write_buf' '. stream_write_buf_size' '. str
if has_rewind
  export '. rewind_limit'
  export '. rewind_open' '. rewind' '. rewind_close'


export '. name' '. is_open' '. is_crashed' '. recover'


export '. name' '. is_open' '. is_crashed' '. recover'