-- Copyright 1993-1998, by the Cecil Project
-- Department of Computer Science and Engineering, University of Washington
-- See the LICENSE file for license information.

--DOC The `string' type is an abstract class representing an indexed
--DOC sequence of characters. Methods operating on generic strings that
--DOC both take and return strings, in most cases produce a new string as
--DOC a result.

abstract object string isa indexed[char];

-- concatenating behavior

method copy_mutable(s@:string):m_string {
    new_m_vstring_init_from(s, &(c:char){ c }) }


--DOC In addition to all the operations available on other indexed
--DOC collections, characters can be concatenated onto
--DOC the front or back of a string using the `||' infix
--DOC operator. (The `||' operator can also concatenate two strings. This
--DOC behavior is inherited from sequences.)

method ||(s1@:string, s2@:string):string {
    let len1:int := s1.length;
    new_i_vstring_init(len1 + s2.length, &(i:int){
	if(i < len1, { s1!i }, { s2!(i-len1) }) }) }
method ||(s1@:string, c@:char):string {
    s1 || c.as_string }

method ||(c@:char, s2@:string):string {
    c.as_string || s2 }

-- case conversion behavior

method to_upper_case(s@:string):string {
    new_m_vstring_init_from(s, &(c:char){ c.to_upper_case }) }

method to_lower_case(s@:string):string {
    new_m_vstring_init_from(s, &(c:char){ c.to_lower_case }) }


-- some of the following operations probably should be moved up to
-- indexed or even sequence

--DOC The `copy_from' method copies a portion of a string from a start
--DOC index up to (but not including) a stop index (or the end of the
--DOC string, if the stop index is not specified). The `has_{prefix,suffix}'
--DOC functions test whether a string starts with or ends with a
--DOC particular string; the `remove_{prefix,suffix}' functions return a new
--DOC string with the specified prefix or suffix removed, if present, or
--DOC the original string otherwise.

method copy_from(s@:string, start:int):string {
    copy_from(s, start, s.length) }

method copy_from(s@:string, start:int, up_to:int):string {
    let stop_pos:int := min(s.length, up_to);
    let start_pos:int := max(0, start);
    let new_len:int := stop_pos - start_pos;
    if(new_len < 0, { error("up_to value smaller than start"); });
    new_m_vstring_init(new_len, &(i:int){ s!(start_pos+i) }) }

method has_prefix(s@:string, prefix@:string):bool {
    prefix = s.copy_from(0, prefix.length) }
method has_suffix(s@:string, suffix@:string):bool {
    suffix = s.copy_from(s.length-suffix.length, s.length) }
method remove_prefix(s@:string, prefix@:string):string {
    if(s.has_prefix(prefix),
       { s.copy_from(prefix.length, s.length) },
       { s }) }
method remove_suffix(s@:string, suffix@:string):string {
    if(s.has_suffix(suffix),
       { s.copy_from(0, s.length - suffix.length) },
       { s }) }


--DOC The `pad' functions add either blanks or a specified padding
--DOC character to either the front or the back of the string to make it
--DOC be of at least the specified length.

method pad(s@:string, len:int):string {
    pad_right(s, len) }
method pad_right(s@:string, len:int):string {
    pad_right(s, len, ' ') }
method pad_right(s@:string, len:int, padding:char):string {
    if(s.length < len,
       { s || new_m_vstring(len - s.length, padding) },
       { s }) }
method pad_left(s@:string, len:int):string {
    pad_left(s, len, ' ') }
method pad_left(s@:string, len:int, padding:char):string {
    if(s.length < len,
       { new_m_vstring(len - s.length, padding) || s },
       { s }) }

-- printing behavior

method  open_brace(@:string):string { "\"" }
method close_brace(@:string):string { "\"" }

method collection_name(@:string):string { "string" }

method elem_print_string(@:string, char:char, :bool):string {
    as_string(char) }

method print(s@:string):void { s.as_vstring.print; }


--DOC As usual, there are immutable and mutable varieties of strings.

abstract object i_string isa string, i_indexed[char];

abstract object m_string isa string, m_indexed[char];
  method copy(s@:m_string):m_string { s.copy_mutable }
  method write_into_string_at_pos(s1:string, s2:m_string, pos:int):void {
      s1.do_associations(&(i:int, c:char){
	  s2!(i+pos) := c;
      });
  }


--DOC The `vstring' class and its two concrete subclasses, `i_vstring' and
--DOC `m_vstring', provide a primitive fixed-length packed string
--DOC implementation. Cecil string literals (e.g., `"hello"') are instances
--DOC of `i_vstring'. Various constructors for `vstring's are provided,
--DOC analogously to vectors and arrays.

abstract object vstring isa string;

method length(s@:vstring):int {
    prim
      rtl: "decl int len := num_elems_int s;
	    decl OOP lenOop := box_int len;
	    return lenOop;"
}

method fetch(s@:vstring, index:int, if_absent:&():char):char {
    prim
      rtl: "if is_int_log index goto index_OK;
	    fatal \"can only index into vstrings with ints\";
	label index_OK;
	    decl int i := unbox_int index;
            decl int len := num_elems_int s;
            if i <_unsigned_log len goto bounds_OK;
            decl OOP t5 := send eval(if_absent);
            return t5;
        label bounds_OK;
            decl char t6 := s[i] char;
            decl OOP t7 := box_char t6;
            return t7;
" }


method as_vstring(s@:vstring):vstring { s }

-- this primitive can be used, even if unix_files aren't defined
method print(s@:vstring):void (** return_type(void), sends(),
			          does_io, formals_escape(f) **) {
  prim c_++: "
    char* b = VEC_ELEMS(s,char);
    int len = NUM_ELEMS(s);
    fwrite(b, 1, len, stdout);
    // fwrite does an automatic flush if string ended in c/r
    if(len > 0 && b[len-1] != '\\n') {
      fflush(stdout);
    }
#ifdef DISPATCHERS
    RETURN(BASE(void));
#else
    BP(BASE(void));
#endif
  "
}

-- immutable strings (e.g. string literals)

extend i_vstring isa i_string, vstring;

method new_i_vstring(size@:int):i_vstring { new_i_vstring(size, ' ') }
method new_i_vstring(size@:int, filler_oop@:char):i_vstring {
    prim rtl: "
        decl int len := unbox_int size;
        if len >=_int_log 0 goto OK;
	len := 0;
      label OK;
        decl OOP s := new_i_string len;
        if len =_int_log 0 goto exit;
	decl char filler := unbox_char filler_oop;
        decl int i := 0;
      label l;
	s[i] char := filler;
        i := i +_int 1;
  	if i <_int_log len goto l;
      label exit;
        return s;
" }
method new_i_vstring_init(size@:int, cl:&(int):char):i_vstring {
  prim rtl: "
        decl int len := unbox_int size;
        if len >=_int_log 0 goto OK;
	len := 0;
      label OK;
        decl OOP s := new_i_string len;
        if len =_int_log 0 goto exit;
        decl int i := 0;
      label l;
        decl OOP tagged_i := box_int i;
	decl OOP elem_oop := send eval(cl, tagged_i);
	if is_char_log elem_oop goto elem_OK;
	fatal \"can only store chars in vstrings\";
      label elem_OK;
	decl char elem := unbox_char elem_oop;
	s[i] char := elem;
	i := i +_int 1;
	if i <_int_log len goto l;
      label exit;
        return s;
" }

method new_i_vstring_init_from(c@:ordered_collection[`T],
			       cl:&(T):char):i_vstring {
    let s:stream[T] := view_stream(c);
    new_i_vstring_init(c.length, &(i:int){ eval(cl, s.next) }) }

method new_i_vstring_init_from(c@:indexed[`T], cl:&(T):char
			       ):i_vstring (** inline **) {
    new_i_vstring_init(c.length, &(i:int){ eval(cl, c!i) }) }


-- mutable fixed-length strings

extend m_vstring isa m_string, vstring;

method new_m_vstring(size@:int):m_vstring {
    new_m_vstring(size, ' ') }

-- This method is very low-level: the characters in the string constructed
-- by this method are undefined.  Presumably the caller will be filling in
-- the characters afterwards.  By calling this method, an initial
-- initialization of the string to some filler character can be skipped.
method new_m_vstring_no_init(size@:int):m_vstring {
    prim
      rtl: "
        decl int len := unbox_int size;
        if len >=_int_log 0 goto OK;
	len := 0;
      label OK;
        decl OOP s := new_m_string len;
        return s;"
 }

method new_m_vstring(size@:int, filler_oop@:char):m_vstring {
    prim rtl: "
        decl int len := unbox_int size;
        if len >=_int_log 0 goto OK;
	len := 0;
      label OK;
        decl OOP s := new_m_string len;
        if len =_int_log 0 goto exit;
	decl char filler := unbox_char filler_oop;
        decl int i := 0;
      label l;
	s[i] char := filler;
        i := i +_int 1;
  	if i <_int_log len goto l;
      label exit;
        return s;
" }

method new_m_vstring_init(size@:int, cl:&(int):char):m_vstring {
  prim rtl: "
        decl int len := unbox_int size;
        if len >=_int_log 0 goto OK;
	len := 0;
      label OK;
        decl OOP s := new_m_string len;
        if len =_int_log 0 goto exit;
        decl int i := 0;
      label l;
        decl OOP tagged_i := box_int i;
	decl OOP elem_oop := send eval(cl, tagged_i);
	if is_char_log elem_oop goto elem_OK;
	fatal \"can only store chars in vstrings\";
      label elem_OK;
	decl char elem := unbox_char elem_oop;
	s[i] char := elem;
	i := i +_int 1;
	if i <_int_log len goto l;
      label exit;
        return s;
" }

method new_m_vstring_init_from(c@:ordered_collection[`T],
			       cl:&(T):char):m_vstring {
    let s:stream[T] := view_stream(c);
    new_m_vstring_init(c.length, &(i:int){ eval(cl, s.next) }) }

method new_m_vstring_init_from(c@:indexed[`T], cl:&(T):char
			       ):m_vstring (** inline **) {
    new_m_vstring_init(c.length, &(i:int){ eval(cl, c!i) }) }


method store(s@:m_vstring, index:int, c:char, if_absent:&():void):void {
    prim
      rtl: "if is_int_log index goto index_OK;
	    fatal \"can only index into vstrings with ints\";
	label index_OK;
	    if is_char_log c goto c_OK;
	    fatal \"can only store chars in vstrings\";
	label c_OK;
	    decl wordInt i := unbox_int index;
            decl wordInt len := num_elems_int s;
            if i <_unsigned_log len goto bounds_OK;
            decl OOP t5 := send eval(if_absent);
            return void;
	label bounds_OK;
            decl char t6 := unbox_char c;
            s[i] char := t6;
            return void;
" }

method as_m_vstring(s@:m_vstring):m_vstring { s }