Module:    internal
Author:    Jonathan Bachrach
Copyright:    Original Code is Copyright (c) 1995-2004 Functional Objects, Inc.
              All rights reserved.
License:      Functional Objects Library Public License Version 1.0
Dual-license: GNU Lesser General Public License
Warranty:     Distributed WITHOUT WARRANTY OF ANY KIND


// BOOTED: define ... abstract class <string> ... end;


/////////////////
// IMPLEMENTATION
/////////////////


// STRING

//
// AS
//

define sealed inline method as (class == <string>, string :: <string>) 
    => (s :: <string>)
  string
end method as;

define method as (class == <string>, collection :: <collection>)
     => (bs :: <byte-string>)
  as(<byte-string>, collection)
end method as;


//
// MAKE
//

define sealed inline method make (class == <string>, #key size = 0, fill = ' ')
 => (result :: <byte-string>)
  make(<byte-string>, size: size, fill: fill)
end method make;

// 
// SHARED STRING
// 

define macro shared-string-definer
  { define shared-string ?:name (#key ?fill:expression) }
    => { define method make
	      (class == "<" ## ?name ## "-string>", 
	       #key fill :: "<" ## ?name ## "-character>" = ?fill, size :: <integer> = 0)
	   => (res :: "<" ## ?name ## "-string>")
	   if (size = 0)
	     empty(class)
	   else
	     system-allocate-repeated-instance
	       ("<" ## ?name ## "-string>", "<" ## ?name ## "-character>", unbound(), size, fill);
	   end if
	 end method; 

         define sealed inline method concrete-limited-string-class
             (of == "<" ## ?name ## "-character>")
          => (type :: singleton("<" ## ?name ## "-string>"))
           "<" ## ?name ## "-string>"
         end method;

         define inline sealed method element
	     (string :: "<" ## ?name ## "-string>", index :: <integer>,
	      #key default = unsupplied())
	  => (character :: "<" ## ?name ## "-character>")
	   if (element-range-check(index, size(string)))
	     string-element(string, index)
	   else
	     if (unsupplied?(default))
	       element-range-error(string, index)
	     else 
	       check-type(default, element-type(string));
	       default
	     end if
	   end if
	 end method element;

         define inline sealed method element-no-bounds-check
	     (string :: "<" ## ?name ## "-string>", index :: <integer>, #key default)
		  => (character :: "<" ## ?name ## "-character>")
	   string-element(string, index)
	 end method element-no-bounds-check;

	 define inline sealed method element-setter 
	     (new-value :: "<" ## ?name ## "-character>", 
	      string :: "<" ## ?name ## "-string>", index :: <integer>)
		 => (character :: "<" ## ?name ## "-character>")
	   if (element-range-check(index, size(string)))
	     string-element(string, index) := new-value
	   else
	     element-range-error(string, index)
	   end if
	 end method element-setter;

         define inline sealed method element-setter
             (new-value :: <character>,
              string :: "<" ## ?name ## "-string>", index :: <integer>)
          => (character :: "<" ## ?name ## "-character>")
           string[index] := as("<" ## ?name ## "-character>", new-value);
         end method element-setter;

	 define inline sealed method element-no-bounds-check-setter 
	     (new-value :: "<" ## ?name ## "-character>", 
	      string :: "<" ## ?name ## "-string>", index :: <integer>)
		 => (character :: "<" ## ?name ## "-character>")
	   string-element(string, index) := new-value
	 end method element-no-bounds-check-setter;

         define inline sealed method element-no-bounds-check-setter
             (new-value :: <character>,
              string :: "<" ## ?name ## "-string>", index :: <integer>)
          => (character :: "<" ## ?name ## "-character>")
           string-element(string, index)
             := as("<" ## ?name ## "-character>", new-value);
         end method element-no-bounds-check-setter;

	 define sealed inline method type-for-copy
	     (object :: "<" ## ?name ## "-string>") => (c :: <class>)
	   "<" ## ?name ## "-string>"
	 end method type-for-copy;

         define sealed inline method element-type 
	     (t :: "<" ## ?name ## "-string>") => (type :: <type>)
	   "<" ## ?name ## "-character>"
	 end method;

	 define sealed inline method as
	     (class == "<" ## ?name ## "-string>", string :: "<" ## ?name ## "-string>")
	  => (s :: "<" ## ?name ## "-string>")
	   string
	 end method as;

	 define method as
	     (class == "<" ## ?name ## "-string>", collection :: <collection>)
	  => (s :: "<" ## ?name ## "-string>")
	   let new-string :: "<" ## ?name ## "-string>"
	     = make("<" ## ?name ## "-string>", size: collection.size);
	   replace-subsequence!(new-string, collection);
	   new-string
	 end method as;

	 define inline function ?name ## "-string-current-element"
	     (string :: "<" ## ?name ## "-string>", state :: <integer>)
	   string-element(string, state)
	 end function;

	 define inline function ?name ## "-string-current-element-setter"
	     (new-value :: <character>, string :: "<" ## ?name ## "-string>", 
	      state :: <integer>)
	   string-element(string, state) := as("<" ## ?name ## "-character>", new-value);
	 end function;

	 define sealed inline method forward-iteration-protocol 
	   (sequence :: "<" ## ?name ## "-string>")
	     => (initial-state :: <integer>, limit :: <integer>,
		 next-state :: <function>, finished-state? :: <function>,
		 current-key :: <function>,
		 current-element :: <function>, current-element-setter :: <function>,
		 copy-state :: <function>)
	   values(0,
		  sequence.size,
		  sequence-next-state,
		  sequence-finished-state?,
		  sequence-current-key,
		  ?name ## "-string-current-element",
		  ?name ## "-string-current-element-setter",
		  identity-copy-state)
	 end method forward-iteration-protocol;

	 define sealed inline method backward-iteration-protocol 
	   (sequence :: "<" ## ?name ## "-string>")
	     => (final-state :: <integer>,
		 limit :: <integer>,
		 previous-state :: <function>,
		 finished-state? :: <function>,
		 current-key :: <function>,
		 current-element :: <function>,
		 current-element-setter :: <function>,
		 copy-state :: <function>)
	   values(sequence.size - 1,
		  -1,
		  sequence-previous-state,
		  sequence-finished-state?,
		  sequence-current-key,
		  ?name ## "-string-current-element",
		  ?name ## "-string-current-element-setter",
		  identity-copy-state)
	 end method backward-iteration-protocol;

	 define sealed domain size ("<" ## ?name ## "-string>");
	 define sealed domain make (singleton("<" ## ?name ## "-string>"));
	 define sealed domain initialize ("<" ## ?name ## "-string>");

	 define inline sealed method empty?
	     (string :: "<" ## ?name ## "-string>") => (result :: <boolean>)
	   string.size = 0
	 end method empty?;

	 define sealed method \<
	     (string-1 :: "<" ## ?name ## "-string>", string-2 :: "<" ## ?name ## "-string>")
	  => (well? :: <boolean>)
	   let min-size :: <integer> = min(string-1.size, string-2.size);
	   iterate grovel (index :: <integer> = 0)
	     if (index >= min-size)
	       string-1.size < string-2.size
	     else
	       let character-1 = string-element(string-1, index);
	       let character-2 = string-element(string-2, index);
	       if (character-1 = character-2)
		 grovel(index + 1)
	       else
		 character-1 < character-2
	       end if
	     end if
	   end iterate
	 end method \<;

	 define sealed method \=
	     (string-1 :: "<" ## ?name ## "-string>", string-2 :: "<" ## ?name ## "-string>")
	  => (eq :: <boolean>)
	   unless (string-1.size ~= string-2.size)
	     for (c1 :: "<" ## ?name ## "-character>" in string-1, 
		  c2 :: "<" ## ?name ## "-character>" in string-2,
		  eq = #t then c1 == c2,
		  while: eq)
	     finally 
	       eq
	     end
	   end
	 end;

	 define sealed method case-insensitive-equal
	     (string-1 :: "<" ## ?name ## "-string>", string-2 :: "<" ## ?name ## "-string>")
	  => (eq :: <boolean>)
	   unless (string-1.size ~= string-2.size)
	     for (c1 :: "<" ## ?name ## "-character>" in string-1, 
		  c2 :: "<" ## ?name ## "-character>" in string-2,
		  eq = #t then c1 == c2 | as-lowercase(c1) == as-lowercase(c2),
		  while: eq)
	     finally 
	       eq
	     end
	   end
	 end;

	 define sealed method as-lowercase (string :: "<" ## ?name ## "-string>") 
	  => (new-string :: "<" ## ?name ## "-string>")
	   let new-string :: "<" ## ?name ## "-string>" 
	     = make("<" ## ?name ## "-string>", size: string.size);
	   for (i :: <integer> from 0 below string.size) 
	     string-element(new-string, i)
	       := as-lowercase(string-element(string, i))
	   end for;   
	   new-string
	 end method as-lowercase;

	 define sealed method as-lowercase! (string :: "<" ## ?name ## "-string>") 
 	  => (string :: "<" ## ?name ## "-string>")
	   for (i :: <integer> from 0 below string.size) 
	     string-element(string, i)
	       := as-lowercase(string-element(string, i))
	   end for;   
	   string
	 end method as-lowercase!;

	 define sealed method as-uppercase (string :: "<" ## ?name ## "-string>") 
	  => (new-string :: "<" ## ?name ## "-string>")
	   let new-string :: "<" ## ?name ## "-string>" 
	     = make("<" ## ?name ## "-string>", size: string.size);
	   for (i :: <integer> from 0 below string.size) 
	     string-element(new-string, i)
	       := as-uppercase(string-element(string, i))
	   end for;   
	   new-string
	 end method as-uppercase;

	 define sealed method as-uppercase! (string :: "<" ## ?name ## "-string>") 
	     => (string :: "<" ## ?name ## "-string>")
	   for (i :: <integer> from 0 below string.size) 
	     string-element(string, i)
	       := as-uppercase(string-element(string, i))
	   end for;   
	   string
	 end method as-uppercase!; 
         }
end macro;

define macro string-definer
  { define string ?:name (#key ?fill:expression) }
    => { define shared-string ?name (fill: ?fill);
         define sealed concrete primary class "<" ## ?name ## "-string>" (<string>, <vector>)
	   repeated sealed inline slot string-element :: "<" ## ?name ## "-character>",
	     init-value: ?fill,
	     init-keyword: fill:,
	     size-getter: size,
	     size-init-keyword: size:,
	     size-init-value: 0;
	 end class;

         define constant "$empty-<" ## ?name ## "-string>"
           = system-allocate-repeated-instance
               ("<" ## ?name ## "-string>", "<" ## ?name ## "-character>", unbound(), 0, ?fill);

	 define sealed method empty
	     (class == "<" ## ?name ## "-string>") => (res :: "<" ## ?name ## "-string>")
          "$empty-<" ## ?name ## "-string>"
	 end method; }
end macro;

define constant <string-type>
  = type-union(subclass(<string>), <limited-string-type>);

define method limited-string
    (of :: <type>, size :: false-or(<integer>)) => (type :: <string-type>)
  let concrete-class
    = concrete-limited-string-class(of);
  if (size)
    make(<limited-string-type>,
	 class:          <string>,
	 element-type:   of,
	 concrete-class: concrete-class,
	 size:           size)
  else 
    concrete-class
  end if;
end method;

//
// BYTE-STRING
//

// BOOTED: define ... class <byte-string> ... end;


define shared-string byte (fill: ' ');

define sealed method empty
    (class == <byte-string>) => (res :: <byte-string>)
 ""
end method; 

define inline method system-allocate-repeated-instance
    (class == <byte-string>, type == <byte-character>, fill, 
     repeated-size :: <integer>, repeated-fill :: <byte-character>)
 => (instance :: <byte-string>)
  system-allocate-repeated-byte-instance-terminated
    (<byte-string>, repeated-size, repeated-fill);
end method;