# New Ticket Created by Vasily Chekalkin
# Please include the string: [perl #57936]
# in the subject line of all future correspondence about this issue.
# <URL: http://rt.perl.org/rt3/Ticket/Display.html?id=57936 >
Hello.
Trivial and initial implementation of StrPos attached.
--
Bacek
diff --git a/languages/perl6/src/builtins/any-str.pir
b/languages/perl6/src/builtins/any-str.pir
index 3516a44..ba56169 100644
--- a/languages/perl6/src/builtins/any-str.pir
+++ b/languages/perl6/src/builtins/any-str.pir
@@ -46,6 +46,7 @@ the size of that file down and to emphasize their generic,
.param int pos :optional
.param int has_pos :opt_flag
.local pmc retv
+ .local pmc strposproto
if has_pos goto have_pos
pos = 0
@@ -54,6 +55,8 @@ the size of that file down and to emphasize their generic,
.local string s
s = self
+ strposproto = get_hll_global 'StrPos'
+
check_substring:
if substring goto substring_search
$I0 = length s
@@ -66,12 +69,11 @@ the size of that file down and to emphasize their generic,
if pos < 0 goto fail
done:
- $P0 = new 'Int'
- $P0 = pos
+ $P0 = strposproto.'new'('pos'=>pos)
.return ($P0)
fail:
- $P0 = new 'Failure'
+ $P0 = strposproto.'new'()
.return ($P0)
.end
diff --git a/languages/perl6/src/classes/Str.pir
b/languages/perl6/src/classes/Str.pir
index bc36b82..c058c6a 100644
--- a/languages/perl6/src/classes/Str.pir
+++ b/languages/perl6/src/classes/Str.pir
@@ -9,6 +9,8 @@ Str - Perl 6 Str class and related functions
This file sets up the C<Perl6Str> PMC type (from F<src/pmc/perl6str.pmc>)
as the Perl 6 C<Str> class.
+Also implements StrPos type as described in S29.
+
=head1 Methods
=over 4
@@ -20,7 +22,7 @@ as the Perl 6 C<Str> class.
.include 'cclass.pasm'
.sub 'onload' :anon :init :load
- .local pmc p6meta, strproto
+ .local pmc p6meta, strproto, strposproto
p6meta = get_hll_global ['Perl6Object'], '$!P6META'
strproto = p6meta.'new_class'('Str', 'parent'=>'Perl6Str Any')
p6meta.'register'('Perl6Str', 'parent'=>strproto, 'protoobject'=>strproto)
@@ -28,6 +30,8 @@ as the Perl 6 C<Str> class.
$P0 = get_hll_namespace ['Str']
'!EXPORT'('sprintf', 'from'=>$P0)
+
+ strproto = p6meta.'new_class'('StrPos', 'parent'=>'Any', 'attr'=>'$!pos')
.end
@@ -451,10 +455,6 @@ Note: Most users should just let their I/O handles
autochomp instead.
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 pos
@@ -482,6 +482,77 @@ Should replace vec with declared arrays of bit, uint2,
uint4, etc.
=cut
+.namespace ['StrPos']
+
+=over
+
+=item get_bool
+
+=cut
+
+.sub 'get_bool' :vtable :method
+ .local pmc pos
+ pos = getattribute self, '$!pos'
+ $I0 = defined pos
+ .return ($I0)
+.end
+
+=item defined
+
+Synonim for C<get_bool>
+
+=cut
+
+.sub 'defined' :vtable :method
+ # Tailcall is broken...
+ # .return self.'get_bool'()
+ $I0 = self.'get_bool'()
+ .return ($I0)
+.end
+
+=item get_pos
+
+Get stored position with defaulting to 0 and issuing warning if undefined.
+
+=cut
+
+.sub 'get_pos' :method
+ .local pmc pos
+ pos = getattribute self, '$!pos'
+ $I0 = defined pos
+ if $I0 goto ret_val
+ # TODO Issue warning or call fail()
+ pos = 0
+ ret_val:
+ .return (pos)
+.end
+
+=item get_integer
+
+Integer version of C<get_pos>
+
+=cut
+
+.sub 'get_integer' :vtable :method
+ $P0 = self.'get_pos'()
+ $I0 = $P0
+ .return ($I0)
+.end
+
+=item get_string
+
+String version of C<get_pos>
+
+=cut
+
+.sub 'get_string' :vtable :method
+ $P0 = self.'get_pos'()
+ $S0 = $P0
+ .return ($S0)
+.end
+
+=back
+
# Local Variables:
# mode: pir
# fill-column: 100
