Str.pir

=head1 TITLE

Str - Perl 6 Str class and related functions

=head1 DESCRIPTION

This file sets up the C<Perl6Str> PMC type (from F<src/pmc/perl6str.pmc>)
as the Perl 6 C<Str> class.

=head1 Methods

=over 4

=cut

.namespace ['Str']

.include 'cclass.pasm'

.sub 'onload' :anon :init :load
    .local pmc p6meta, strproto
    p6meta = get_hll_global ['Perl6Object'], '$!P6META'
    strproto = p6meta.'new_class'('Str', 'parent'=>'parrot;Perl6Str Any')
    strproto.'!IMMUTABLE'()
    p6meta.'register'('Perl6Str', 'parent'=>strproto, 'protoobject'=>strproto)
    p6meta.'register'('String', 'parent'=>strproto, 'protoobject'=>strproto)

    $P0 = get_hll_namespace ['Str']
    '!EXPORT'('sprintf', 'from'=>$P0)
.end


.sub 'ACCEPTS' :method
    .param string topic
    .tailcall 'infix:eq'(topic, self)
.end


=item perl()

Returns a Perl representation of the Str.

=cut

.sub 'perl' :method
    .local string str, result
    str = self
    result = '"'
    .local int pos
    pos = 0
    .local pmc arr
    arr = root_new ['parrot';'ResizablePMCArray']
  loop:
    .local string ch
    ch = substr str, pos, 1
    if ch == '' goto done
    if ch == ' ' goto loop_ch
    ##  check for special escapes
    $I0 = index  "$ @ % & { \b \n \r \t \\ \"", ch
    if $I0 < 0 goto loop_nonprint
    ch = substr  "\\$\\@\\%\\&\\{\\b\\n\\r\\t\\\\\\\"", $I0, 2
    goto loop_ch
  loop_nonprint:
    $I0 = is_cclass .CCLASS_PRINTING, ch, 0
    if $I0 goto loop_ch
    $I0 = ord ch
    arr[0] = $I0
    ch = sprintf '\x[%x]', arr
  loop_ch:
    result .= ch
    inc pos
    goto loop
  done:
    result .= '"'
    .return (result)
.end


=item sprintf( *@args )

=cut

.sub 'sprintf' :method
    .param pmc args            :slurpy
    args.'!flatten'()
    $P0 = new ['Str']
    push_eh args_fail
    sprintf $P0, self, args
    pop_eh
    .return ($P0)
  args_fail:
    pop_eh
    .tailcall '!FAIL'('Insufficient arguments supplied to sprintf')
.end

=item succ and pred

Increment and Decrement Methods

=cut

.namespace ['Str']

## The RANGES constant indicates the successor to each character in
## a defined range.  ## Currently supported increment/decrement ranges:
##    0..9   ASCII digits  (U+0030..U+0039)
##    A..Z   ASCII uc       (U+0041..U+005a)
##    a..z   ASCII lc       (U+0061..U+006a)
##    Α..Ω   Greek uc       (U+0391..U+03a9, skip u+03a2)
##    α..ω   Greek lc       (U+03b1..U+03c9, skip u+03c2)
##    Ⅰ..Ⅻ   clock roman uc (U+2160..U+216b)
##    ⅰ..ⅻ   clock roman lc (U+2170..U+217b)
##    ①..⑳   circled digits (U+2460..U+2473)
##    ⑴..⒇   parenth digits (U+2474..U+2487)
##    ⒜..⒵   parenth lc     (U+249c..U+24b5)
##    ⚀..⚅   die faces      (U+2680..U+2685)
## Note that in each cycle, the first character of the cycle is repeated
## at the end of the cycle (to indicate carries).

.const string RANGES = unicode:"01234567890ABCDEFGHIJKLMNOPQRSTUVWXYZAabcdefghijklmnopqrstuvwxyza\u0391\u0392\u0393\u0394\u0395\u0396\u0397\u0398\u0399\u039a\u039b\u039c\u039d\u039e\u039f\u03a0\u03a1\u03a3\u03a4\u03a5\u03a6\u03a7\u03a8\u03a9\u0391\u03b1\u03b2\u03b3\u03b4\u03b5\u03b6\u03b7\u03b8\u03b9\u03ba\u03bb\u03bc\u03bd\u03be\u03bf\u03c0\u03c1\u03c3\u03c4\u03c5\u03c6\u03c7\u03c8\u03c9\u03b1\u2160\u2161\u2162\u2163\u2164\u2165\u2166\u2167\u2168\u2169\u216a\u216b\u2160\u2170\u2171\u2172\u2173\u2174\u2175\u2176\u2177\u2178\u2179\u217a\u217b\u2170\u2460\u2461\u2462\u2463\u2464\u2465\u2466\u2467\u2468\u2469\u246a\u246b\u246c\u246d\u246e\u246f\u2470\u2471\u2472\u2473\u2460\u2474\u2475\u2476\u2477\u2478\u2479\u247a\u247b\u247c\u247d\u247e\u247f\u2480\u2481\u2482\u2483\u2484\u2485\u2486\u2487\u2474\u249c\u249d\u249e\u249f\u24a0\u24a1\u24a2\u24a3\u24a4\u24a5\u24a6\u24a7\u24a8\u24a9\u24aa\u24ab\u24ac\u24ad\u24ae\u24af\u24b0\u24b1\u24b2\u24b3\u24b4\u24b5\u249c\u2680\u2681\u2682\u2683\u2684\u2685\u2680"

.sub '!range_pos' :anon
    .param string str

    .local int len, pos, r0, r1
    len = length str

    # Scan from the end of a string for a character that is in RANGES.
    # This is the potential end of the substring to be incremented.
    pos = len
  scan_loop:
    # Reset range positions to indicate that we haven't found a valid substr
    r0 = 0
    r1 = -1
  scan_end_loop:
    unless pos > 0 goto done
    dec pos
    $S0 = substr str, pos, 1
    $I0 = index RANGES, $S0
    if $I0 < 0 goto scan_end_loop

    # we found a candidate end of the range, now scan for start
    r1 = pos
  scan_start_loop:
    # if we reach the beginning of the string, the range starts at pos 0
    unless pos > 0 goto done
    dec pos
    $S0 = substr str, pos, 1
    # if we find a dot: this isn't a valid range, scan again
    if $S0 == '.' goto scan_loop
    # if we find a valid character, keep scanning
    $I0 = index RANGES, $S0
    if $I0 >= 0 goto scan_start_loop
    # pos + 1 is the start of the range, we're done
    r0 = pos + 1

  done:
    .return (r0, r1)
.end


.sub 'pred' :method
    .local string str
    str = self
    str = clone str

    .local int r0, r1, ipos
    (r0, r1) = '!range_pos'(str)
    if r1 < 0 goto done

  dec_1:
    .local string orig, repl
    orig = substr str, r1, 1
    ipos = index RANGES, orig 
    $I0 = ipos + 1
    $I0 = index RANGES, orig, $I0
    if $I0 < 0 goto dec_2
    ipos = $I0
  dec_2:
    dec ipos
    repl = substr RANGES, ipos, 1
    substr str, r1, 1, repl
    # if the replacement wasn't a carry, we're done
    if orig > repl goto done
  carry:
    # if there are more characters in the range, decrement those first
    dec r1
    if r1 >= r0 goto dec_1
  extend:
    .tailcall '!FAIL'('Decrement out of range')

  done:
    .return (str)
.end


.sub 'succ' :method
    .local string str
    str = self
    str = clone str

    .local int r0, r1, ipos
    (r0, r1) = '!range_pos'(str)
    if r1 < 0 goto done

  inc_1:
    .local string orig, repl
    orig = substr str, r1, 1
    ipos = index RANGES, orig 
    inc ipos
    .local string repl
    repl = substr RANGES, ipos, 1
    substr str, r1, 1, repl
    # if the replacement wasn't a carry, we're done
    if orig < repl goto done
  carry:
    # if there are more characters in the range, increment those first
    dec r1
    if r1 >= r0 goto inc_1
  extend:
    # insert a new character based on the previous one
    unless repl == '0' goto extend_1
    repl = '1'
  extend_1:
    substr str, r0, 0, repl

  done:
    .return (str)
.end


=item WHICH()

Returns the identify value.

=cut

.sub 'WHICH' :method
    $S0 = self
    .return ($S0)
.end


=back

=head1 Functions

=over 4

=cut

.namespace []

.include 'cclass.pasm'


=item infix:===

Overridden for Str.

=cut

.namespace []
.sub 'infix:===' :multi(String,String)
    .param string a
    .param string b
    $I0 = iseq a, b
    .tailcall 'prefix:?'($I0)
.end


=back

=head2 TODO Functions

=over 4

=item length

This word is banned in Perl 6.  You must specify units.

=item index

Needs to be in terms of StrPos, not Int.

=item pack

=item quotemeta

=item rindex

Needs to be in terms of StrPos, not Int.

=item sprintf

=item unpack

=item vec

Should replace vec with declared arrays of bit, uint2, uint4, etc.

=item words

 our List multi Str::words ( Rule $matcher = /\S+/,  Str $input = $+_, Int $limit = inf )
 our List multi Str::words ( Str $input : Rule $matcher = /\S+/, Int $limit = inf )

=back

=cut

# Local Variables:
#   mode: pir
#   fill-column: 100
# End:
# vim: expandtab shiftwidth=4 ft=pir: