From 9a15b82be117e9cd6dec67c17f91a0cf2fd2a911 Mon Sep 17 00:00:00 2001 From: Moritz Lenz Date: Fri, 21 May 2010 20:43:36 +0200 Subject: [PATCH] remove src/old/. If you want it back, run "git checkout alpha" --- src/old/builtins-old/any-list.pir | 221 -- src/old/builtins-old/any-num.pir | 104 - src/old/builtins-old/any-str.pir | 883 ------ src/old/builtins-old/assign.pir | 364 --- src/old/builtins-old/cmp.pir | 136 - src/old/builtins-old/compiler.pir | 72 - src/old/builtins-old/control.pir | 605 ---- src/old/builtins-old/eval.pir | 276 -- src/old/builtins-old/globals.pir | 183 -- src/old/builtins-old/guts.pir | 1515 ---------- src/old/builtins-old/io.pir | 227 -- src/old/builtins-old/match.pir | 58 - src/old/builtins-old/math.pir | 165 -- src/old/builtins-old/named-unary.pir | 69 - src/old/builtins-old/op.pir | 545 ---- src/old/builtins-old/system.pir | 66 - src/old/classes/Abstraction.pir | 22 - src/old/classes/Array.pir | 321 --- src/old/classes/Associative.pir | 130 - src/old/classes/AttributeDeclarand.pir | 42 - src/old/classes/Capture.pir | 109 - src/old/classes/Code.pir | 164 -- src/old/classes/ContainerDeclarand.pir | 45 - src/old/classes/Exception.pir | 45 - src/old/classes/Failure.pir | 134 - src/old/classes/Hash.pir | 259 -- src/old/classes/IO.pir | 44 - src/old/classes/Iterator.pir | 31 - src/old/classes/Junction.pir | 532 ---- src/old/classes/List.pir | 619 ----- src/old/classes/Mapping.pir | 392 --- src/old/classes/Match.pir | 72 - src/old/classes/Module.pir | 49 - src/old/classes/Multi.pir | 47 - src/old/classes/Nil.pir | 87 - src/old/classes/Object.pir | 957 ------- src/old/classes/Order.pir | 58 - src/old/classes/Pair.pir | 89 - src/old/classes/Range.pir | 290 -- src/old/classes/Regex.pir | 99 - src/old/classes/Routine.pir | 37 - src/old/classes/Signature.pir | 124 - src/old/classes/Submethod.pir | 31 - src/old/classes/Whatever.pir | 25 - src/old/classes/WhateverCode.pir | 77 - src/old/parrot/P6Invocation.pir | 39 - src/old/parrot/misc.pir | 104 - src/old/parrot/signature.pir | 22 - src/old/parrot/state.pir | 79 - src/old/parser/actions.pm | 3515 ------------------------ src/old/parser/expression.pir | 60 - src/old/parser/grammar-oper.pg | 204 -- src/old/parser/grammar.pg | 1091 -------- src/old/parser/methods.pir | 172 -- src/old/parser/quote_expression.pir | 501 ---- src/old/setting/Any-list.pm | 219 -- src/old/setting/Any-num.pm | 427 --- src/old/setting/Any-str.pm | 245 -- src/old/setting/Array.pm | 47 - src/old/setting/Attribute.pm | 10 - src/old/setting/Block.pm | 53 - src/old/setting/Bool.pm | 28 - src/old/setting/Buf.pm | 17 - src/old/setting/Code.pm | 12 - src/old/setting/Complex.pm | 317 --- src/old/setting/Hash.pm | 73 - src/old/setting/IO.pm | 83 - src/old/setting/IO/Socket.pm | 34 - src/old/setting/IO/Socket/INET.pm | 53 - src/old/setting/Int.pm | 117 - src/old/setting/Junction.pm | 13 - src/old/setting/List.pm | 55 - src/old/setting/Mapping.pm | 15 - src/old/setting/Match.pm | 96 - src/old/setting/NYI.pm | 32 - src/old/setting/Num.pm | 370 --- src/old/setting/Object.pm | 96 - src/old/setting/Operators.pm | 375 --- src/old/setting/Pair.pm | 71 - src/old/setting/Parameter.pm | 27 - src/old/setting/Range.pm | 71 - src/old/setting/Rat.pm | 117 - src/old/setting/Signature.pm | 77 - src/old/setting/Str.pm | 33 - src/old/setting/Temporal.pm | 183 -- src/old/setting/Whatever.pm | 114 - src/old/setting/traits.pm | 101 - 87 files changed, 19788 deletions(-) delete mode 100644 src/old/builtins-old/any-list.pir delete mode 100644 src/old/builtins-old/any-num.pir delete mode 100644 src/old/builtins-old/any-str.pir delete mode 100644 src/old/builtins-old/assign.pir delete mode 100644 src/old/builtins-old/cmp.pir delete mode 100644 src/old/builtins-old/compiler.pir delete mode 100644 src/old/builtins-old/control.pir delete mode 100644 src/old/builtins-old/eval.pir delete mode 100644 src/old/builtins-old/globals.pir delete mode 100644 src/old/builtins-old/guts.pir delete mode 100644 src/old/builtins-old/io.pir delete mode 100644 src/old/builtins-old/match.pir delete mode 100644 src/old/builtins-old/math.pir delete mode 100644 src/old/builtins-old/named-unary.pir delete mode 100644 src/old/builtins-old/op.pir delete mode 100644 src/old/builtins-old/system.pir delete mode 100644 src/old/classes/Abstraction.pir delete mode 100644 src/old/classes/Array.pir delete mode 100644 src/old/classes/Associative.pir delete mode 100644 src/old/classes/AttributeDeclarand.pir delete mode 100644 src/old/classes/Capture.pir delete mode 100644 src/old/classes/Code.pir delete mode 100644 src/old/classes/ContainerDeclarand.pir delete mode 100644 src/old/classes/Exception.pir delete mode 100644 src/old/classes/Failure.pir delete mode 100644 src/old/classes/Hash.pir delete mode 100644 src/old/classes/IO.pir delete mode 100644 src/old/classes/Iterator.pir delete mode 100644 src/old/classes/Junction.pir delete mode 100644 src/old/classes/List.pir delete mode 100644 src/old/classes/Mapping.pir delete mode 100644 src/old/classes/Match.pir delete mode 100644 src/old/classes/Module.pir delete mode 100644 src/old/classes/Multi.pir delete mode 100644 src/old/classes/Nil.pir delete mode 100644 src/old/classes/Object.pir delete mode 100644 src/old/classes/Order.pir delete mode 100644 src/old/classes/Pair.pir delete mode 100644 src/old/classes/Range.pir delete mode 100644 src/old/classes/Regex.pir delete mode 100644 src/old/classes/Routine.pir delete mode 100644 src/old/classes/Signature.pir delete mode 100644 src/old/classes/Submethod.pir delete mode 100644 src/old/classes/Whatever.pir delete mode 100644 src/old/classes/WhateverCode.pir delete mode 100644 src/old/parrot/P6Invocation.pir delete mode 100644 src/old/parrot/misc.pir delete mode 100644 src/old/parrot/signature.pir delete mode 100644 src/old/parrot/state.pir delete mode 100644 src/old/parser/actions.pm delete mode 100644 src/old/parser/expression.pir delete mode 100644 src/old/parser/grammar-oper.pg delete mode 100644 src/old/parser/grammar.pg delete mode 100644 src/old/parser/methods.pir delete mode 100644 src/old/parser/quote_expression.pir delete mode 100644 src/old/setting/Any-list.pm delete mode 100644 src/old/setting/Any-num.pm delete mode 100644 src/old/setting/Any-str.pm delete mode 100644 src/old/setting/Array.pm delete mode 100644 src/old/setting/Attribute.pm delete mode 100644 src/old/setting/Block.pm delete mode 100644 src/old/setting/Bool.pm delete mode 100644 src/old/setting/Buf.pm delete mode 100644 src/old/setting/Code.pm delete mode 100644 src/old/setting/Complex.pm delete mode 100644 src/old/setting/Hash.pm delete mode 100644 src/old/setting/IO.pm delete mode 100644 src/old/setting/IO/Socket.pm delete mode 100644 src/old/setting/IO/Socket/INET.pm delete mode 100644 src/old/setting/Int.pm delete mode 100644 src/old/setting/Junction.pm delete mode 100644 src/old/setting/List.pm delete mode 100644 src/old/setting/Mapping.pm delete mode 100644 src/old/setting/Match.pm delete mode 100644 src/old/setting/NYI.pm delete mode 100644 src/old/setting/Num.pm delete mode 100644 src/old/setting/Object.pm delete mode 100644 src/old/setting/Operators.pm delete mode 100644 src/old/setting/Pair.pm delete mode 100644 src/old/setting/Parameter.pm delete mode 100644 src/old/setting/Range.pm delete mode 100644 src/old/setting/Rat.pm delete mode 100644 src/old/setting/Signature.pm delete mode 100644 src/old/setting/Str.pm delete mode 100644 src/old/setting/Temporal.pm delete mode 100644 src/old/setting/Whatever.pm delete mode 100644 src/old/setting/traits.pm diff --git a/src/old/builtins-old/any-list.pir b/src/old/builtins-old/any-list.pir deleted file mode 100644 index 5e83037b5c3..00000000000 --- a/src/old/builtins-old/any-list.pir +++ /dev/null @@ -1,221 +0,0 @@ -## $Id$ - -=head1 NAME - -src/builtins/any-list.pir - C-like functions and methods for C - -=head1 DESCRIPTION - -This file implements the methods and functions of C that -are most closely associated with the C class or role. -We place them here instead of F to keep -the size of that file down and to emphasize their generic, -"built-in" nature. - -=head2 Methods - -=over 4 - -=cut - -=item elems() - -=cut - -.namespace [] -.sub 'elems' :multi() - .param pmc values :slurpy - $P0 = values.'!flatten'() - .tailcall values.'elems'() -.end - -.namespace ['Any'] -.sub 'elems' :method :vtable('elements') :multi(_) - $P0 = self.'list'() - $I0 = $P0.'elems'() - .return ($I0) -.end - - -=item keys() - -Return a List with the keys of the invocant. - -=cut - -.namespace [] -.sub 'keys' :multi() :subid('_keys') - .param pmc values :slurpy - values.'!flatten'() - .tailcall values.'keys'() -.end -.sub '' :init :load - .local pmc block, signature - .const 'Sub' $P0 = "_keys" - block = $P0 - signature = allocate_signature 1 - null $P1 - $I0 = SIG_ELEM_MULTI_INVOCANT + SIG_ELEM_SLURPY_POS - set_signature_elem signature, 0, "@values", $I0, $P1, $P1, $P1, $P1, $P1, $P1 - setprop block, "$!signature", signature - '!TOPERL6MULTISUB'(block) -.end - - -.namespace ['Any'] -.sub 'keys' :method :subid('any_keys') - $I0 = self.'elems'() - $P0 = 'prefix:^'($I0) - .tailcall $P0.'list'() -.end -.sub '' :init :load - .local pmc block, signature - .const 'Sub' $P0 = "any_keys" - block = $P0 - signature = allocate_signature 1 - setprop block, "$!signature", signature - $P0 = get_hll_global 'Any' - null $P1 - set_signature_elem signature, 0, "self", SIG_ELEM_INVOCANT_AND_MULTI_INVOCANT, $P0, $P1, $P1, $P1, $P1, $P1 -.end - -=item sort() - -Sort list. In this case we copy into an FPA to make use of the -Parrot's built-in sort algorithm. - -=cut - -.namespace [] -.sub 'sort' :multi() - .param pmc values :slurpy - .local pmc by - by = find_name 'infix:cmp' - unless values goto have_by - $P0 = values[0] - $I0 = isa $P0, 'Sub' - unless $I0 goto have_by - by = shift values - have_by: - .tailcall values.'sort'(by) -.end - -.namespace ['Any'] -.sub 'sort' :method :multi(_) - .param pmc by :optional - .param int has_by :opt_flag - if has_by goto have_by - by = find_name 'infix:cmp' - have_by: - - ## prepare self for sorting - .local pmc list - .local int elems - list = self.'list'() - elems = list.'elems'() - ## If there are fewer than two elements, no need to sort. - unless elems < 2 goto do_sort - .return (list) - - do_sort: - ## Get the comparison function to use. We don't use C - ## directly, because FPA's sort doesn't work with MultiSub - ## functions and isn't stable. !COMPARESUB expects to be - ## sorting indexes into C, and also handles generation - ## of values for subs with arity < 2. - .local pmc cmp - cmp = '!COMPARESUB'(list, by) - - ## create a FPA of indexes to be sorted using cmp - .local pmc fpa - fpa = root_new ['parrot';'FixedPMCArray'] - assign fpa, elems - $I0 = 0 - fpa_loop: - unless $I0 < elems goto fpa_done - fpa[$I0] = $I0 - inc $I0 - goto fpa_loop - fpa_done: - fpa.'sort'(cmp) - .tailcall list.'postcircumfix:[ ]'(fpa) -.end - -.sub '!COMPARESUB' :anon - .param pmc list - .param pmc by - $I0 = can by, 'arity' - unless $I0 goto have_list - $I0 = by.'arity'() - unless $I0 < 2 goto have_list - list = list.'map'(by) - by = find_name 'infix:cmp' - have_list: - ## Because of TT #56, we can't store Sub PMCs directly into - ## the namespace. So, we create an array to hold it for us. - set_global '@!compare', list - $P0 = root_new ['parrot';'ResizablePMCArray'] - push $P0, by - set_global '@!compare_by', $P0 - .const 'Sub' $P99 = '!COMPARE_DO' - .return ($P99) -.end - -.sub '!COMPARE_DO' :anon - .param int a - .param int b - .local pmc list, by - list = get_global '@!compare' - $P0 = get_global '@!compare_by' - by = $P0[0] - - $P0 = list[a] - $P1 = list[b] - $I0 = by($P0, $P1) - unless $I0 == 0 goto done - $I0 = cmp a, b - done: - .return ($I0) -.end - - -=item values - -Return values of the list - -=cut - -.namespace [] -.sub 'values' :multi() :subid('_values') - .param pmc values :slurpy - .tailcall values.'!flatten'() -.end -.sub '' :init :load - .local pmc block, signature - .const 'Sub' $P0 = "_values" - block = $P0 - signature = allocate_signature 1 - null $P1 - $I0 = SIG_ELEM_MULTI_INVOCANT + SIG_ELEM_SLURPY_POS - set_signature_elem signature, 0, "@values", $I0, $P1, $P1, $P1, $P1, $P1, $P1 - setprop block, "$!signature", signature - '!TOPERL6MULTISUB'(block) -.end - -.namespace ['Any'] -.sub 'values' :method - self.'list'() - .return (self) -.end - - -=back - -=cut - -# Local Variables: -# mode: pir -# fill-column: 100 -# End: -# vim: expandtab shiftwidth=4 ft=pir: - diff --git a/src/old/builtins-old/any-num.pir b/src/old/builtins-old/any-num.pir deleted file mode 100644 index 5ed5f7386c3..00000000000 --- a/src/old/builtins-old/any-num.pir +++ /dev/null @@ -1,104 +0,0 @@ -## $Id$ - -=head1 NAME - -src/builtins/any_num.pir - C-like functions and methods for C - -=head1 DESCRIPTION - -This file implements the methods and functions of C that -are most closely associated with the C class or role. -We place them here instead of F to keep -the size of that file down and to emphasize their generic, -"built-in" nature. - -=head2 Methods - -=over 4 - -=cut - -.namespace [] -.loadlib 'math_ops' -.sub 'onload' :anon :init :load - $P0 = get_hll_namespace ['Any'] - '!EXPORT'('int,polar,truncate', 'from'=>$P0) - - ## pre-seed a random number generator - 'srand'() -.end - -.namespace ['Any'] -.sub 'int' :method :multi(_) - "die"("the int() sub and .int method have been replaced by the .Int method") -.end - -.namespace ['Any'] -.sub 'Int' :method :multi(_) - .tailcall self.'truncate'() -.end - - -=item polar - -=cut - -.namespace ['Any'] -.sub 'polar' :method :multi(_) - $N0 = self - .tailcall 'list'($N0, 0) -.end - - -=item srand() - -=cut - -.namespace [] -.sub 'srand' - .param num seed :optional - .param int has_seed :opt_flag - if has_seed goto have_seed - seed = time - have_seed: - srand seed - .return () -.end - -.namespace ['Any'] -.sub 'srand' :method - $N0 = self - srand $N0 - .return () -.end - - -=item truncate() - -=item int - -=cut - -.namespace ['Any'] -.sub 'truncate' :method :multi(_) - $N0 = self - if $N0 == 0 goto done - if $N0 < 0 goto num_ceil - floor $N0 - goto done - num_ceil: - ceil $N0 - done: - $I0 = $N0 - .return ($I0) -.end - -=back - -=cut - -# Local Variables: -# mode: pir -# fill-column: 100 -# End: -# vim: expandtab shiftwidth=4 ft=pir: diff --git a/src/old/builtins-old/any-str.pir b/src/old/builtins-old/any-str.pir deleted file mode 100644 index ace024022a3..00000000000 --- a/src/old/builtins-old/any-str.pir +++ /dev/null @@ -1,883 +0,0 @@ -## $Id$ - -=head1 NAME - -src/builtins/any-str.pir - C-like functions and methods for C - -=head1 DESCRIPTION - -This file implements the methods and functions of C that -are most closely associated with the C class or role. -We place them here instead of F to keep -the size of that file down and to emphasize their generic, -"built-in" nature. - -=head2 Methods - -=over 4 - -=cut - -.include 'cclass.pasm' - -.namespace [] -.sub 'onload' :anon :init :load - $P0 = get_hll_namespace ['Any'] - '!EXPORT'('chomp,chars,:d,:e,:f,:l,:s,index,rindex,substr', 'from'=>$P0) -.end - - -=item chars() - -=cut - -.namespace ['Any'] - -.sub 'chars' :method :multi(_) - $S0 = self - $I0 = length $S0 - .return ($I0) -.end - -=item chomp - - our Str method Str::chomp ( Str $string: ) - - Returns string with newline removed from the end. An arbitrary - terminator can be removed if the input filehandle has marked the - string for where the "newline" begins. (Presumably this is stored - as a property of the string.) Otherwise a standard newline is removed. - -=cut - -.sub 'chomp' :method :multi(_) - .local string tmps - .local string lastchar - .local pmc retv - - tmps = self - lastchar = substr tmps,-1 - if lastchar != "\n" goto done - chopn tmps, 1 - lastchar = substr tmps,-1 - if lastchar != "\r" goto done - chopn tmps, 1 - done: - retv = new ['Str'] - retv = tmps - .return (retv) -.end - -=item ':d'() - - our Bool multi Str::':d' ( Str $filename ) - -Returns whether the file with the name indicated by the invocant is a -directory. - -=cut - -.sub ':d' :method :multi(_) - .param int arg :optional - .param int has_arg :opt_flag - - .local string filename - filename = self - - push_eh not_a_dir - $I0 = stat filename, 2 - if $I0 goto file_is_a_dir - not_a_dir: - $P0 = get_hll_global ['Bool'], 'False' - .return ($P0) - file_is_a_dir: - $P0 = get_hll_global ['Bool'], 'True' - .return ($P0) -.end - -=item ':e'() - - our Bool multi Str::':e' ( Str $filename ) - -Returns whether the file with the name indicated by the invocant exists. - -=cut - -.sub ':e' :method :multi(_) - .param int arg :optional - .param int has_arg :opt_flag - - .local string filename - filename = self - - $I0 = stat filename, 0 - if $I0 goto file_exists - $P0 = get_hll_global ['Bool'], 'False' - .return ($P0) - file_exists: - $P0 = get_hll_global ['Bool'], 'True' - .return ($P0) -.end - -=item ':f'() - - our Bool multi Str::':f' ( Str $filename ) - -Returns whether the file with the name indicated by the invocant is a plain -file. - -=cut - -.sub ':f' :method :multi(_) - .param int arg :optional - .param int has_arg :opt_flag - - .local string filename - filename = self - - push_eh file_isnt_plain - $I0 = stat filename, 2 - if $I0 goto file_isnt_plain - $P0 = get_hll_global ['Bool'], 'True' - .return ($P0) - file_isnt_plain: - $P0 = get_hll_global ['Bool'], 'False' - .return ($P0) -.end - -=item ':l'() - - our Bool multi Str::':l' ( Str $filename ) - -Returns whether the file with the name indicated by the invocant is a symbolic link. - -=cut - -.sub ':l' :method :multi(_) - .param int arg :optional - .param int has_arg :opt_flag - - .local string filename - filename = self - - .local pmc file - file = root_new ['parrot';'File'] - - $I0 = file.'is_link'(filename) - .return ($I0) -.end - -=item ':s'() - - our Int multi Str::':s' ( Str $filename ) - -Returns file size. - -=cut - -.sub ':s' :method :multi(_) - .param int arg :optional - .param int has_arg :opt_flag - - .local string filename - filename = self - - $I0 = stat filename, 1 - .return ($I0) -.end - -=item index() - -=cut - -.namespace ['Any'] -.sub 'index' :method :multi(_) - .param string substring - .param int pos :optional - .param int has_pos :opt_flag - .local pmc retv - - if has_pos goto have_pos - pos = 0 - have_pos: - - .local string s - s = self - - check_substring: - $I1 = length substring - if $I1 goto substring_search - $I0 = length s - if pos < $I0 goto done - pos = $I0 - goto done - - substring_search: - pos = index s, substring, pos - if pos < 0 goto notfound - - done: - $P0 = new ['Int'] - $P0 = pos - .return ($P0) - - fail: - .tailcall '!FAIL'("Attempt to index from negative position") - notfound: - .tailcall '!FAIL'("Substring '", substring, "' not found in '", s, "'") -.end - -=item match() - -=cut - -.sub 'match' :method :multi(_) - .param pmc x - .local pmc match - match = x.'!invoke'(self) - .return(match) -.end - -=item rindex() - -=cut - -.namespace ['Any'] -.sub 'rindex' :method :multi(_, _) - .param string substring - .param int pos :optional - .param int has_pos :opt_flag - .local pmc retv - - check_substring: - if substring goto substring_search - - # we do not have substring return pos or length - - .local string s - s = self - $I0 = length s - - if has_pos goto have_pos - pos = $I0 - goto done - have_pos: - if pos < $I0 goto done - pos = $I0 - goto done - - substring_search: - $I0 = self.'isa'('String') - if $I0 goto self_string - $P0 = root_new ['parrot';'String'] - $S0 = self - $P0 = $S0 - goto do_search - self_string: - $P0 = self - do_search: - pos = $P0.'reverse_index'(substring, pos) - if pos < 0 goto notfound - - done: - $P0 = new ['Int'] - $P0 = pos - .return ($P0) - - fail: - .tailcall '!FAIL'("Attempt to index from negative position") - notfound: - .tailcall '!FAIL'("Substring '", substring, "' not found in '", s, "'") -.end - -=item substr() - -=cut - -.namespace ['Any'] -.sub 'substr' :method :multi(_, _) - .param int start - .param int len :optional - .param int has_len :opt_flag - - if has_len goto have_len - len = self.'chars'() - have_len: - if len >= 0 goto len_done - if start < 0 goto neg_start - $I0 = self.'chars'() - len += $I0 - neg_start: - len -= start - len_done: - $S0 = self - push_eh fail - $S1 = substr $S0, start, len - pop_eh - $P0 = new ['Str'] - $P0 = $S1 - .return ($P0) - fail: - .get_results($P0) - pop_eh - .tailcall '!FAIL'($P0) -.end - -=item trans() - - Implementation of transliteration - -=cut - -.sub '!transtable' :multi(_) - .param pmc r - .local pmc retval, tmps - retval = root_new ['parrot';'ResizablePMCArray'] - tmps = clone r - range_loop: - unless tmps, done - $P0 = tmps.'shift'() - push retval, $P0 - goto range_loop - done: - .return(retval) -.end - -# Handles Regexes and Closures - -.sub '!transtable' :multi('Sub') - .param pmc r - .local pmc retval - retval = root_new ['parrot';'ResizablePMCArray'] - push retval, r - .return(retval) -.end - -.sub '!transtable' :multi('String') - .param string str - .local pmc retval, prior, frm, to, next_str - .local int start, end, len, ind, skipped, r_start, r_end, s_len - .local string p - retval = root_new ['parrot';'ResizablePMCArray'] - prior = root_new ['parrot';'ResizablePMCArray'] - start = 0 - skipped = 0 - len = length str - end = len - 2 - next_index: - ind = index str, '..' , start - if ind == -1 goto last_string - # ranges can only be after first position, before last one - if ind == 0 goto skip_pos - if ind >= end goto last_string - init_range: - r_start = ind - 1 - r_end = ind + 2 - range_frm: - $S0 = substr str, r_start, 1 - $I0 = ord $S0 - range_to: - $S1 = substr str, r_end, 1 - $I1 = ord $S1 - prev_string: - s_len = r_start - start - s_len += skipped - unless s_len, start_range - p = substr str, start, s_len - prior = split '', p - process_pstring: - unless prior, start_range - $S2 = shift prior - next_str = new ['Str'] - next_str = $S2 - push retval, next_str - goto process_pstring - start_range: - if $I0 > $I1 goto illegal_range - make_range: - # Here we're assuming the ordinal increments correctly for all chars. - # This is a bit naive for now, it definitely needs some unicode testing. - # If needed we can switch this over to use a true string Range - if $I0 > $I1 goto next_loop - $S2 = chr $I0 - next_str = new ['Str'] - next_str = $S2 - push retval, next_str - inc $I0 - goto make_range - illegal_range: - die "Illegal range used in transliteration operator" - next_loop: - start = r_end + 1 - goto next_index - skip_pos: - inc start - inc skipped - goto next_index - last_string: - s_len = len - start - if s_len <= 0 goto check_rval - p = substr str, start, s_len - prior = split '', p - process_lstring: - unless prior, check_rval - $S0 = shift prior - next_str = new ['Str'] - next_str = $S0 - push retval, next_str - goto process_lstring - check_rval: - $I0 = elements retval - if $I0 > 0 goto done - push retval, '' - done: - .return(retval) -.end - - -.sub 'trans' :method - .param pmc args :slurpy - .param pmc adverbs :slurpy :named - .local int del, comp, squash - $I0 = exists adverbs['d'] - $I1 = exists adverbs['delete'] - del = $I0 || $I1 - $I0 = exists adverbs['c'] - $I1 = exists adverbs['complement'] - comp = $I0 || $I1 - $I0 = exists adverbs['s'] - $I1 = exists adverbs['squash'] - squash = $I0 || $I1 - # TODO: unspec'd behavior: above arguments are similar - # to p5 tr/// but are not described in S05, need some - # clarification on whether these are implemented correctly - .local pmc table, itable, retv, comp_match, by - .local int len, klen, vlen, adjpos, pos, ind, nhits - by = get_hll_global 'infix:<=>' - # itable maps matching positions to key, value array - itable = new ['Perl6Hash'] - retv = new ['Str'] - - init_pair_loop: - .local pmc pair, pkey, pval, pairlist - .local int isatype - pair_loop: - unless args, init_trans - pair = shift args - # following is a cludge to get around list context issues - # should be removed once that works - isatype = isa pair, 'Perl6Pair' - if isatype goto isa_pair - isatype = isa pair, 'Hash' - if isatype goto isa_hash - isatype = isa pair, 'List' - if isatype goto isa_list - # change to Failure? - die "Must pass a List of Pairs for transliteration" - isa_hash: - pairlist = pair.'pairs'() - goto pairlist_loop - isa_list: - pairlist = clone pair - pairlist_loop: - unless pairlist, pair_loop - pair = shift pairlist - push args, pair - goto pairlist_loop - isa_pair: - pkey = pair.'key'() - pval = pair.'value'() - pkey = '!transtable'(pkey) - pval = '!transtable'(pval) - vlen = elements pval - if vlen goto comp_check - if del goto comp_check - pval = clone pkey - comp_check: - # for :c, I am using first element for replacing for now. I can't find - # any reliable examples where this is used otherwise - comp_match = pval[0] - - init_mapping: - .local pmc key, val, lastval, prev_val, prev_key - .local string tmps - .local int prev_pos, k_isa_regex - tmps = self - mapping: - .local pmc match, km - unless pkey, pair_loop - key = shift pkey - unless pval, get_prev1 - lastval = shift pval - get_prev1: - if del, get_prev2 - val = lastval - goto init_index_loop - get_prev2: - val = new ['Str'] - val = '' - init_index_loop: - nhits = 0 - pos = 0 - prev_pos = 0 - # assume key is always a Str for now (will need to adjust for Regex) - k_isa_regex = isa key, 'Sub' # should be Regex - unless k_isa_regex, index_loop - - regex_loop: - match = key(tmps, 'continue' => pos) - unless match goto mapping - ind = match.'from'() - km = match - inc nhits - goto check_hit - index_loop: - km = key - # change over to index method - $S0 = key - ind = index tmps, $S0, pos - if ind == -1 goto mapping - inc nhits - check_hit: - klen = km.'chars'() # should work for Match, Str - $I0 = exists itable[ind] - unless $I0, new_hit - prev_key = itable[ind;0] - # keep longest hit at that index - $I1 = prev_key.'chars'() - if klen < $I1 goto next_hit - new_hit: - $P1 = root_new ['parrot';'ResizablePMCArray'] - push $P1, km - push $P1, val - itable[ind] = $P1 - next_hit: - prev_pos = ind - pos = ind + klen - prev_val = val - unless k_isa_regex goto index_loop - # Do we just grab the next match (which may backtrack), or only grab longest - # match? This will affect closures ... - goto regex_loop - - init_trans: - .local pmc hit_set, inv_set, inv_table, it - .local int kvdiff, llm, pr_pos, st, end - .local string vs - hit_set = root_new ['parrot';'ResizableIntegerArray'] - normal_hits: - hit_set = itable.'keys'() - hit_set = hit_set.'sort'(by) - unless comp, st_trans - comp_hits: - # if :c is indicated, rebuild complement set and use that instead - # of original itable - inv_table = new ['Perl6Hash'] - st = 0 - end = 0 - len = length tmps - inv_set = root_new ['parrot';'ResizableIntegerArray'] - it = hit_set.'iterator'() - comp_loop1: - unless it, fence_post - end = shift it - key = itable[end;0] - klen = key.'chars'() - comp_loop2: - if st == len goto finish_comp - if st == end goto comp_loop3 - # TODO: unspec'd behavior - # depending on how we want to implement complement, we could - # modify the following to replace the entire unmatched range once - # or each char (latter implemented for now to match tests) - push inv_set, st - $P1 = root_new ['parrot';'ResizablePMCArray'] - push $P1, 'x' # placeholder char; we can replace with substr if needed - push $P1, comp_match - inv_table[st] = $P1 - inc st - goto comp_loop2 - comp_loop3: - st += klen - goto comp_loop1 - fence_post: - end = len - goto comp_loop2 - finish_comp: - hit_set = inv_set - itable = inv_table - - st_trans: - .local int k_isa_match, v_isa_closure, pass_match - .local pmc lastmatch, v - lastmatch = new ['Str'] - lastmatch = '' - pos = 0 # original unadjusted position - pr_pos = 0 # prior unadjusted position - adjpos = 0 # adjusted position - kvdiff = 0 # key-value string length diff - klen = 0 # key len - vlen = 0 # val len - llm = 0 # orig end marker for longest leftmost match - tmps = self # reassig; workaround for [perl #59730] - - table_loop: - unless hit_set, done - pos = shift hit_set - if pos < llm goto table_loop - key = itable[pos;0] - k_isa_match = isa key, ['PGE';'Match'] - klen = key.'chars'() - # skip matches between pos and end of llm - llm = pos + klen - val = itable[pos;1] - v_isa_closure = isa val, 'Sub' - pass_match = k_isa_match && v_isa_closure - unless v_isa_closure, not_closure - unless pass_match, simple_closure - regex_closure: - val = val(key) - goto not_closure - simple_closure: - val = val() - not_closure: - vlen = val.'chars'() - check_squash: - unless squash, replace - # should these be stringified prior to squash? - unless lastmatch goto replace - unless val == lastmatch goto replace - $I0 = pos - prev_pos - unless $I0 == klen goto replace - vlen = 0 - prev_pos = pos - pos += adjpos - substr tmps, pos, klen, '' - goto next_pos - replace: - prev_pos = pos - pos += adjpos - $S0 = val - substr tmps, pos, klen, $S0 - next_pos: - kvdiff = klen - vlen - adjpos -= kvdiff - lastmatch = val - goto table_loop - - done: - retv = tmps - .return(retv) -.end - - -=item subst - - our Str method Str::subst ( Any $string: Any $substring, Any $replacement ) - our Str method Str::subst ( Any $string: Code $regexp, Any $replacement ) - -Replaces the first occurrence of a given substring or a regular expression -match with some other substring. - -Partial implementation. The :g modifier on regexps doesn't work, for example. - -=cut - -.sub 'subst' :method :multi(_, _, _) - .param string substring - .param string replacement - .param pmc options :slurpy :named - - .local pmc global_flag - global_flag = options['global'] - unless null global_flag goto have_global - global_flag = options['g'] - unless null global_flag goto have_global - global_flag = get_hll_global ['Bool'], 'False' - have_global: - - .local int times # how many times to substitute - times = 1 # the default is to substitute once - unless global_flag goto check_x - times = -1 # a negative number means all of them (:global) - check_x: - - .local pmc x_opt - x_opt = options['x'] - if null x_opt goto check_nth - times = x_opt - if times < 0 goto x_fail - check_nth: - - .local pmc nth_opt - nth_opt = options['nth'] - unless null nth_opt goto check_global - nth_opt = get_hll_global ['Bool'], 'True' - check_global: - - - .local string result - result = self - result = clone result - - if times == 0 goto subst_done - - .local int startpos, pos, substringlen, replacelen - startpos = 0 - pos = 0 - substringlen = length substring - replacelen = length replacement - .local int n_cnt, x_cnt - n_cnt = 0 - x_cnt = 0 - subst_loop: - pos = index result, substring, startpos - startpos = pos + substringlen - if pos < 0 goto subst_done - - n_cnt += 1 - $P0 = nth_opt.'ACCEPTS'(n_cnt) - unless $P0 goto subst_loop - - if times < 0 goto skip_times - - x_cnt += 1 - if x_cnt > times goto subst_done - skip_times: - - substr result, pos, substringlen, replacement - startpos = pos + replacelen - goto subst_loop - subst_done: - if null x_opt goto x_check_done - if n_cnt >= times goto x_check_done - .return (self) - x_check_done: - .return (result) - - nth_fail: - 'die'("Must pass a non-negative integer to :nth()") - - x_fail: - 'die'("Must pass a non-negative integer to :x()") -.end - - -.sub 'subst' :method :multi(_, 'Sub', _) - .param pmc regex - .param pmc replacement - .param pmc options :slurpy :named - - .local pmc global_flag - global_flag = options['global'] - unless null global_flag goto have_global - global_flag = options['g'] - unless null global_flag goto have_global - global_flag = get_hll_global ['Bool'], 'False' - have_global: - - - .local int times # how many times to substitute - times = 1 # the default is to substitute once - unless global_flag goto check_x - times = -1 # a negative number means all of them (:global) - check_x: - - .local pmc x_opt - x_opt = options['x'] - if null x_opt goto check_nth - times = x_opt - if times < 0 goto x_fail - check_nth: - - .local pmc nth_opt - nth_opt = options['nth'] - unless null nth_opt goto build_matches - nth_opt = get_hll_global ['Bool'], 'True' - - build_matches: - .local string source, result - source = self - result = clone source - - if times == 0 goto subst_done - - # build a list of matches - .local pmc matchlist, match - .local int n_cnt, x_cnt - n_cnt = 0 - x_cnt = 0 - matchlist = root_new ['parrot';'ResizablePMCArray'] - match = regex.'!invoke'(source) - unless match goto matchlist_done - - matchlist_loop: - n_cnt += 1 - $P0 = nth_opt.'ACCEPTS'(n_cnt) - unless $P0 goto skip_push - - if times < 0 goto skip_times - - x_cnt += 1 - if x_cnt > times goto matchlist_done - skip_times: - - push matchlist, match - skip_push: - - $I0 = match.'to'() - match = regex(match, 'continue'=>$I0) - unless match goto matchlist_done - goto matchlist_loop - matchlist_done: - - # get caller's lexpad - .local pmc lexpad - $P0 = getinterp - lexpad = $P0['lexpad';1] - - # now, perform substitutions on matchlist until done - .local int offset - offset = 0 - subst_loop: - unless matchlist goto subst_done - match = shift matchlist - lexpad['$/'] = match - # get substitution string - .local string replacestr - $I0 = isa replacement, 'Sub' - if $I0 goto replacement_sub - replacestr = replacement - goto have_replacestr - replacement_sub: - replacestr = replacement(match) - have_replacestr: - # perform the replacement - $I0 = match.'from'() - $I1 = match.'to'() - $I2 = $I1 - $I0 - $I0 += offset - substr result, $I0, $I2, replacestr - $I3 = length replacestr - $I3 -= $I2 - offset += $I3 - goto subst_loop - subst_done: - if null x_opt goto x_check_done - if n_cnt >= times goto x_check_done - .return (self) - x_check_done: - .return (result) - - nth_fail: - die "Must pass a non-negative integer to :nth()" - - x_fail: - die "Must pass a non-negative integer to :x()" -.end - -# Local Variables: -# mode: pir -# fill-column: 100 -# End: -# vim: expandtab shiftwidth=4 ft=pir: diff --git a/src/old/builtins-old/assign.pir b/src/old/builtins-old/assign.pir deleted file mode 100644 index 111864cf095..00000000000 --- a/src/old/builtins-old/assign.pir +++ /dev/null @@ -1,364 +0,0 @@ -## $Id$ - -=head1 NAME - -src/builtins/assign.pir - assignments - -=head1 Functions - -=over 4 - -=cut - -.namespace [] -.sub 'infix:=' :multi(_,_) - .param pmc cont - .param pmc source - - .local pmc ro, type - getprop ro, 'readonly', cont - if null ro goto ro_ok - unless ro goto ro_ok - 'die'('Cannot assign to readonly variable.') - ro_ok: - - $I0 = isa cont, 'Perl6Scalar' - if $I0 goto obj_store - $I0 = can cont, '!STORE' - unless $I0 goto obj_store - .tailcall cont.'!STORE'(source) - - obj_store: - .const 'Sub' STORE = 'Object::!STORE' - .tailcall STORE(cont, source) -.end - - -# What follows exists for the benefit of calling this op from C. Turns out -# Parrot_call_sub won't handle multis, and also there's That Tailcall Bug. -.sub '!only_infix:=' - .param pmc cont - .param pmc source - $P0 = 'infix:='(cont, source) - .return ($P0) -.end - - -.sub '!REDUCEMETAOP' - .param string opname - .param pmc identity - .param pmc args # already :slurpy array by caller - - args.'!flatten'() - if args goto reduce - if identity == 'fail' goto fail - if identity == 'list' goto list - .return (identity) - - fail: - .tailcall '!FAIL'() - list: - .tailcall 'list'() - - reduce: - opname = concat 'infix:', opname - .local pmc opfunc - opfunc = find_name opname - .local pmc result - result = shift args - reduce_loop: - unless args goto reduce_done - $P0 = shift args - result = opfunc(result, $P0) - goto reduce_loop - reduce_done: - .return (result) -.end - - -.sub '!REDUCEMETAOPCHAIN' - .param string opname - .param string identity - .param pmc args # already :slurpy array by caller - - .local int want_true - want_true = identity == 'True' - - args.'!flatten'() - $I0 = elements args - if $I0 > 1 goto reduce - if want_true goto true - false: - $P0 = get_hll_global [ 'Bool' ], 'False' - .return ($P0) - true: - $P0 = get_hll_global [ 'Bool' ], 'True' - .return ($P0) - - reduce: - opname = concat 'infix:', opname - .local pmc opfunc - opfunc = find_name opname - .local pmc a, b - b = shift args - reduce_loop: - unless args goto reduce_done - a = b - b = shift args - $I0 = opfunc(a, b) - unless $I0 goto false - goto reduce_loop - reduce_done: - goto true -.end - - -.sub '!ASSIGNMETAOP' - .param string opname - .param pmc a - .param pmc b - - $I0 = defined a - if $I0 goto have_a - $S0 = concat 'prefix:[', opname - concat $S0, ']' - $P1 = find_name $S0 - $P0 = $P1() - 'infix:='(a, $P0) - have_a: - - opname = concat 'infix:', opname - $P1 = find_name opname - $P0 = $P1(a, b) - 'infix:='(a, $P0) - .return (a) -.end - - -.sub '!HYPEROP' - .param string opname - .param pmc a - .param pmc b - .param int dwim_lhs - .param int dwim_rhs - - # If we have a hash, go to the hyper op for hashes implementation. - $P0 = get_hll_global 'Associative' - $I0 = $P0.'ACCEPTS'(a) - unless $I0 goto not_hash - $I0 = $P0.'ACCEPTS'(b) - unless $I0 goto not_hash - .tailcall '!HYPEROPHASH'(opname, a, b, dwim_lhs, dwim_rhs) - not_hash: - - # Make sure they're both lists. - a = a.'list'() - b = b.'list'() - - # Ensure lengths are the same. - .local int elems_a, elems_b - elems_a = a.'elems'() - elems_b = b.'elems'() - if elems_a < elems_b goto extend_lhs - if elems_b < elems_a goto extend_rhs - goto go_hyper - - # Extend LHS if needed. - .local pmc extend_with - extend_lhs: - unless dwim_lhs goto incompatible - if elems_a > 0 goto have_elems_a - extend_with = '!FAIL'() - a = 'infix:xx'(extend_with, elems_b) - goto go_hyper - have_elems_a: - extend_with = a[-1] - $I0 = elems_b - elems_a - extend_with = 'infix:xx'(extend_with, $I0) - a = 'list'(a, extend_with) - goto go_hyper - - # Extend RHS if needed. - extend_rhs: - unless dwim_rhs goto incompatible - if elems_b > 0 goto have_elems_b - extend_with = '!FAIL'() - b = 'infix:xx'(extend_with, elems_a) - goto go_hyper - have_elems_b: - extend_with = b[-1] - $I0 = elems_a - elems_b - extend_with = 'infix:xx'(extend_with, $I0) - b = 'list'(b, extend_with) - goto go_hyper - - # Create result list and get iterators over the two. - go_hyper: - .local pmc result, it_a, it_b - result = new ['Perl6Array'] - it_a = iter a - it_b = iter b - - # Go over them and do the op, recursing if we see a nested array. - .local pmc opfunc, cur_a, cur_b - .local int array_a, array_b - $S0 = concat 'infix:', opname - opfunc = find_name $S0 - loop: - unless it_a goto loop_end - cur_a = shift it_a - cur_b = shift it_b - array_a = isa cur_a, 'Perl6Array' - array_b = isa cur_b, 'Perl6Array' - if array_a goto nested_array_lhs - if array_b goto nested_array_rhs - $P0 = opfunc(cur_a, cur_b) - push result, $P0 - goto loop - - # Handle nested arrays. - nested_array_lhs: - if array_b goto recurse - unless dwim_rhs goto incompatible - cur_b = 'list'(cur_b) - goto recurse - nested_array_rhs: - if array_a goto recurse - unless dwim_lhs goto incompatible - cur_a = 'list'(cur_a) - recurse: - $P0 = '!HYPEROP'(opname, cur_a, cur_b, dwim_lhs, dwim_rhs) - $P0 = root_new ['parrot';'Perl6Scalar'], $P0 - push result, $P0 - goto loop - - loop_end: - .return (result) - - incompatible: - 'die'("Non-dwimmy hyperoperator cannot be used on arrays of different sizes or dimensions.") -.end - - -.sub '!HYPEROPHASH' - .param string opname - .param pmc a - .param pmc b - .param int dwim_lhs - .param int dwim_rhs - - # First, work out applicable keys. - .local pmc keys_applicable, it - keys_applicable = root_new ['parrot';'ResizablePMCArray'] - $I0 = dwim_lhs * dwim_rhs - if $I0 goto intersection - $I0 = dwim_lhs + dwim_rhs - unless $I0 goto union - if dwim_rhs goto keys_a - keys_applicable = b.'keys'() - goto have_applicable_keys - keys_a: - keys_applicable = a.'keys'() - goto have_applicable_keys - - intersection: - it = iter a - intersection_it_loop: - unless it goto intersection_it_loop_end - $P0 = shift it - $I0 = b.'exists'($P0) - unless $I0 goto intersection_it_loop - push keys_applicable, $P0 - goto intersection_it_loop - intersection_it_loop_end: - goto have_applicable_keys - - union: - it = iter a - union_it_loop_a: - unless it goto union_it_loop_a_end - $P0 = shift it - push keys_applicable, $P0 - goto union_it_loop_a - union_it_loop_a_end: - it = iter b - union_it_loop_b: - unless it goto union_it_loop_b_end - $P0 = shift it - $I0 = a.'exists'($P0) - if $I0 goto union_it_loop_b - push keys_applicable, $P0 - goto union_it_loop_b - union_it_loop_b_end: - goto have_applicable_keys - - have_applicable_keys: - .local pmc opfunc, result - $S0 = concat 'infix:', opname - opfunc = find_name $S0 - result = new ['Perl6Hash'] - it = iter keys_applicable - it_loop: - unless it goto it_loop_end - $P0 = shift it - # XXX Would be nice to do: - # $P1 = a.'postcircumfix:{ }'($P0) - # $P2 = b.'postcircumfix:{ }'($P0) - # But we can't until the auto-vivification-on-read bug is fixed. - $P1 = a[$P0] - unless null $P1 goto got_first - $P1 = 'undef'() - got_first: - $P2 = b[$P0] - unless null $P2 goto got_second - $P2 = 'undef'() - got_second: - $P3 = opfunc($P1, $P2) - result[$P0] = $P3 - goto it_loop - it_loop_end: - - .return (result) -.end - - -.sub '!CROSSMETAOP' - .param string opname - .param string identity - .param int chain - .param pmc args :slurpy - - # Use the X operator to get all permutation lists. - .local pmc lists - lists = 'infix:X'(args :flat) - - # Go over the lists and combine them with reduce meta-op. - .local pmc result, it, combinder - if chain goto chain_reduce - combinder = find_name '!REDUCEMETAOP' - goto combinder_done - chain_reduce: - combinder = find_name '!REDUCEMETAOPCHAIN' - combinder_done: - result = 'list'() - it = iter lists - it_loop: - unless it goto it_loop_end - $P0 = shift it - $P0 = combinder(opname, identity, $P0) - push result, $P0 - goto it_loop - it_loop_end: - - .return (result) -.end - -=back - -=cut - -# Local Variables: -# mode: pir -# fill-column: 100 -# End: -# vim: expandtab shiftwidth=4 ft=pir: diff --git a/src/old/builtins-old/cmp.pir b/src/old/builtins-old/cmp.pir deleted file mode 100644 index 383d7fa0eaa..00000000000 --- a/src/old/builtins-old/cmp.pir +++ /dev/null @@ -1,136 +0,0 @@ -## $Id$ - -=head1 NAME - -src/builtins/cmp.pir - Perl6 comparison builtins - -=head1 Functions - -=over 4 - -=cut - -.namespace [] - -.sub 'infix:==' :multi(_,_) - .param num a - .param num b - $I0 = iseq a, b - .tailcall 'prefix:?'($I0) -.end - - -.sub 'infix:<=>' :multi(_,_) - .param pmc a - .param pmc b - $I0 = cmp_num a, b - if $I0 < 0 goto increase - if $I0 > 0 goto decrease - $P0 = get_hll_global ['Order'], 'Same' - .return ($P0) - increase: - $P0 = get_hll_global ['Order'], 'Increase' - .return ($P0) - decrease: - $P0 = get_hll_global ['Order'], 'Decrease' - .return ($P0) -.end - - -.sub 'infix:eq' :multi(_,_) - .param string a - .param string b - $I0 = iseq a, b - .tailcall 'prefix:?'($I0) -.end - - -.sub 'infix:lt' :multi(_,_) - .param string a - .param string b - $I0 = islt a, b - .tailcall 'prefix:?'($I0) -.end - - -.sub 'infix:le' :multi(_,_) - .param string a - .param string b - $I0 = isle a, b - .tailcall 'prefix:?'($I0) -.end - - -.sub 'infix:gt' :multi(_,_) - .param string a - .param string b - $I0 = isgt a, b - .tailcall 'prefix:?'($I0) -.end - - -.sub 'infix:ge' :multi(_,_) - .param string a - .param string b - $I0 = isge a, b - .tailcall 'prefix:?'($I0) -.end - - -.sub 'infix:cmp' :multi(_,_) - .param pmc a - .param pmc b - $I0 = cmp a, b - ## Don't use a tailcall here due to RT#56448 - $P0 = 'infix:<=>'($I0, 0) - .return ($P0) -.end - - -.sub 'infix:===' :multi(_,_) - .param pmc a - .param pmc b - $I0 = '!SAMETYPE_EXACT'(a, b) - unless $I0 goto false - $P0 = a.'WHICH'() - $P1 = b.'WHICH'() - .tailcall 'infix:==='($P0, $P1) - false: - $P0 = get_hll_global [ 'Bool' ], 'False' - .return ($P0) -.end - - -.sub 'infix:!===' :multi(_,_) - .param pmc a - .param pmc b - $P0 = 'infix:==='(a, b) - .tailcall 'prefix:!'($P0) -.end - - -.sub 'infix:=:=' :multi(_,_) - .param pmc a - .param pmc b - $I0 = issame a, b - .return ($I0) -.end - - -.sub 'infix:!=:=' :multi(_,_) - .param pmc a - .param pmc b - $P0 = 'infix:=:='(a, b) - .tailcall 'prefix:!'($P0) -.end - - -=back - -=cut - -# Local Variables: -# mode: pir -# fill-column: 100 -# End: -# vim: expandtab shiftwidth=4 ft=pir: diff --git a/src/old/builtins-old/compiler.pir b/src/old/builtins-old/compiler.pir deleted file mode 100644 index b53221877ea..00000000000 --- a/src/old/builtins-old/compiler.pir +++ /dev/null @@ -1,72 +0,0 @@ -## $Id$ - -=head1 NAME - -src/builtins/compiler.pir - various Perl6::Compiler methods - -=head1 Methods - -=over 4 - -=cut - -.namespace ['Perl6';'Compiler'] - -.sub 'import' :method - .param pmc exportns - .param pmc symbols :slurpy - .param pmc options :slurpy :named - - $P0 = self.'parse_name'(exportns) - exportns = get_hll_namespace $P0 - if null exportns goto end - - .local pmc importns - importns = options['import_to'] - if null importns goto import_caller_ns - $P0 = self.'parse_name'(importns) - importns = get_hll_namespace $P0 - goto have_importns - import_caller_ns: - $P0 = getinterp - $P0 = $P0['sub';1] - importns = $P0.'get_namespace'() - have_importns: - - .local pmc symbols_it - symbols_it = iter symbols - symbols_loop: - unless symbols_it goto symbols_done - .local string symtag - symtag = shift symbols_it - $S0 = substr symtag, 0, 1 - if $S0 == ':' goto symbols_tag - $P0 = exportns[$S0] - importns[$S0] = $P0 - goto symbols_loop - - symbols_tag: - symtag = substr symtag, 1 - .local pmc tagns - tagns = exportns.'get_name'() - push tagns, 'EXPORT' - push tagns, symtag - tagns = get_root_namespace tagns - if null tagns goto tagns_done - .local pmc tagns_it - tagns_it = iter tagns - tagns_loop: - unless tagns_it goto tagns_done - $S0 = shift tagns_it - $P0 = tagns[$S0] - importns[$S0] = $P0 - goto tagns_loop - tagns_done: - goto symbols_loop - symbols_done: - end: -.end - -=back - -=cut diff --git a/src/old/builtins-old/control.pir b/src/old/builtins-old/control.pir deleted file mode 100644 index 0a307eea233..00000000000 --- a/src/old/builtins-old/control.pir +++ /dev/null @@ -1,605 +0,0 @@ -## $Id$ - -=head1 NAME - -src/builtins/control.pir - Perl 6 Control functions - -=head1 Functions - -=over 4 - -=cut - - -.namespace [] -## TODO: get the next line to work -## .namespace [ 'Control::Basic' ] - - -=item return - -Create a return exception. (Only handles 1 return value for -the moment -- we'll do more complex handling a bit later.) - -=cut - -.include 'except_types.pasm' -.include 'except_severity.pasm' - -.sub 'return' - .param pmc value :optional - .param int has_value :opt_flag - - if has_value goto have_value - value = new ['Nil'] - have_value: - $P0 = root_new ['parrot';'Exception'] - $P0['type'] = .CONTROL_RETURN - setattribute $P0, 'payload', value - throw $P0 - .return (value) -.end - - -=item fail - -=cut - -.sub '!FAIL' - .param pmc args :slurpy - if args goto message_args - .local string message - message = 'Use of uninitialized value' - goto have_message - message_args: - message = join '', args - have_message: - $P0 = root_new ['parrot';'Exception'] - $P0['message'] = message - $P1 = new ['Failure'] - setattribute $P1, '$!exception', $P0 - .return ($P1) -.end - -.sub 'fail' - .param pmc value :optional - .param int has_value :opt_flag - .local pmc result - if has_value goto have_value - result = '!FAIL'() - goto done - have_value: - result = '!FAIL'(value) - done: - 'return'(result) - .return(result) -.end - -=item take - -=cut - -.sub 'take' - .param pmc value - - $P0 = root_new ['parrot';'Exception'] - $P0['type'] = .CONTROL_TAKE - $P0['severity'] = .EXCEPT_NORMAL - $P0['message'] = 'take without gather' - setattribute $P0, 'payload', value - throw $P0 - .return (value) -.end - -=item gather - -=cut - -.sub 'gather' - .param pmc block - .local pmc list - .local pmc eh - list = 'list'() - eh = root_new ['parrot';'ExceptionHandler'] - eh.'handle_types'(.CONTROL_TAKE) - set_addr eh, handler - push_eh eh - block() - pop_eh - .return (list) - handler: - .local pmc exception, continuation - .local string message - .get_results(exception) - message = exception['message'] - continuation = exception['resume'] - $P0 = exception['payload'] - list.'push'($P0) - continuation() -.end - -=item last - -=cut - -.sub 'last' - .local pmc e - e = root_new ['parrot';'Exception'] - e['severity'] = .EXCEPT_NORMAL - e['type'] = .CONTROL_LOOP_LAST - throw e -.end - -=item next - -=cut - -.sub 'next' - .local pmc e - e = root_new ['parrot';'Exception'] - e['severity'] = .EXCEPT_NORMAL - e['type'] = .CONTROL_LOOP_NEXT - throw e -.end - -=item redo - -=cut - -.sub 'redo' - .local pmc e - e = root_new ['parrot';'Exception'] - e['severity'] = .EXCEPT_NORMAL - e['type'] = .CONTROL_LOOP_REDO - throw e -.end - -=item continue - -=cut - -.sub 'continue' - .local pmc e - e = root_new ['parrot';'Exception'] - e['severity'] = .EXCEPT_NORMAL - e['type'] = .CONTROL_CONTINUE - throw e -.end - -=item break - -=cut - -.sub 'break' - .param pmc arg :optional - .param int has_arg :opt_flag - .local pmc e - e = root_new ['parrot';'Exception'] - e['severity'] = .EXCEPT_NORMAL - e['type'] = .CONTROL_BREAK - unless has_arg, no_arg - e['payload'] = arg - no_arg: - throw e -.end - -=item term:... - -=cut - -.sub '...' - .param pmc message :optional - .param int have_message :opt_flag - if have_message goto message_done - message = new ['Str'] - message = "Attempt to execute stub code (...)" - message_done: - 'fail'(message) -.end - - -=item die - -=cut - -.sub 'die' :multi('Exception') - .param pmc ex - .local pmc p6ex - p6ex = new ['Perl6Exception'] - setattribute p6ex, '$!exception', ex - set_global '$!', p6ex - throw ex - .return () -.end - -.sub 'die' :multi(_) - .param pmc list :slurpy - .local string message - .local pmc p6ex - .local pmc ex - - message = join '', list - if message > '' goto have_message - message = "Died\n" - have_message: - p6ex = new ['Perl6Exception'] - ex = root_new ['parrot';'Exception'] - ex = message - ex['severity'] = .EXCEPT_FATAL - ex['type'] = .CONTROL_ERROR - setattribute p6ex, '$!exception', ex - set_global '$!', p6ex - throw ex - .return () -.end - - -=item exit - - multi Control::Basic::exit ( Int $status = 0) - -Stops all program execution, and returns C<$status> to the calling environment. - -=cut - -.sub 'exit' - .param int status :optional - .param int has_status :opt_flag - - if has_status goto x - status = 0 - x: - exit status -.end - - -=item nothing - - multi Control::Basic::nothing () - -No operation. Literally does nothing. - -=cut - -.sub 'nothing' -.end - - -=item sleep - - our Num multi Control::Basic::sleep ( Num $for = Inf ) - -Attempt to sleep for up to C<$for> seconds. Implementations are obligated -to support subsecond resolutions if that is at all possible. - -[Q: what about multithreading? do we just sleep this thread? need -to coordinate with entire async model. -law] - -=cut - -.sub 'sleep' - .param num a :optional - .param int has_a :opt_flag - if has_a goto have_a - a = 2147483647 # FIXME: RT #57294 - have_a: - $N0 = time - sleep a - $N1 = time - $N2 = $N1 - $N0 - .return ($N2) -.end - - -=item time - - our Time sub Control::Basic::time() - -XXX Should be returning a (currently unspec'd, it seems) Time object that -numifies to a floating point value giving the number of seconds and -fractional seconds since 2000. At the moment, just handing back what the -Parrot time opcode does, since that doesn't give something with a consistent -epoch. Mails sent about both issues, will fix when answers come back. - -=cut - -.sub 'time' - $N0 = time - .return ($N0) -.end - - -=item eval - - multi Control::Basic::eval ( Str $code, Grammar :$lang = CALLER::<$?PARSER>) - -Execute C<$code> as if it were code written in C<$lang>. The default -is the language in effect at the exact location of the eval call. - -Returns whatever C<$code> returns, or undef on error. Sets caller's C<$!> -on error. - -=cut - -.sub 'eval' - .param pmc code - .param pmc lang :named('lang') :optional - .param int have_lang :opt_flag - - $P0 = get_hll_global 'Str' - $I0 = $P0.'ACCEPTS'(code) - if $I0 goto type_ok - 'die'("Parameter type check failed on call to 'eval'.") - type_ok: - - # We want to make the lexicals known to the Perl 6 compiler. (One day - # PCT maybe will provide a way to tell any language about these.) - .local pmc blocks, block_info, interp, sub, my_caller - interp = getinterp - $P0 = get_hll_global ['PAST'], 'Block' - block_info = $P0.'new'() - my_caller = interp["sub"; 1] - set sub, my_caller - lex_loop: - if null sub goto lex_loop_end - $P0 = sub.'get_lexinfo'() - if null $P0 goto symbols_loop_end - $P0 = inspect $P0, 'symbols' - $P0 = iter $P0 - symbols_loop: - unless $P0 goto symbols_loop_end - $S0 = shift $P0 - block_info.'symbol'($S0, 'scope'=>'lexical') - goto symbols_loop - symbols_loop_end: - sub = sub.'get_outer'() - goto lex_loop - lex_loop_end: - blocks = get_hll_global ['Perl6';'Grammar';'Actions'], '@?BLOCK' - block_info['eval'] = 1 - blocks.'unshift'(block_info) - - # Also set namespace. - $P0 = my_caller.'get_namespace'() - $P0 = $P0.'get_name'() - $S0 = shift $P0 - block_info.'namespace'($P0) - - .local pmc compiler, invokable - .local pmc res, exception, parrotex - unless have_lang goto no_lang - push_eh catch - $S0 = lang - $S1 = downcase $S0 - load_language $S1 - compiler = compreg $S0 - goto got_lang - no_lang: - push_eh catch - compiler = compreg 'perl6' - got_lang: - invokable = compiler.'compile'(code) - if have_lang goto invoke_direct - - # Clear lexical info we added. - blocks.'shift'() - - # Set lexical scope. - $P1 = invokable[0] - $P1.'set_outer'(my_caller) - - # Invoke. - invoke_direct: - res = invokable() - exception = '!FAIL'() - goto done - - catch: - .get_results (parrotex) - exception = new ['Perl6Exception'] - setattribute exception, '$!exception', parrotex - - done: - pop_eh - - # Propagate exception to caller - $P0 = getinterp - $P0 = $P0['lexpad';1] - $P0['$!'] = exception - unless null res goto with_res - res = new ['Nil'] - with_res: - .return (res) -.end - -=item warn - -=cut - -.sub 'warn' - .param pmc list :slurpy - .local pmc ex - .local string message - - message = list.'join'('') - if message > '' goto have_message - message = "Warning! Something's wrong.\n" - have_message: - ## count_eh is broken - # $I0 = count_eh - # eq $I0, 0, no_eh - ex = root_new ['parrot';'Exception'] - ex['severity'] = .EXCEPT_WARNING - ex['message'] = message - throw ex - .return () - no_eh: - .local pmc err - err = get_hll_global "$ERR" - err.'print'(message) - .return () -.end - - -=item callwith - -=cut - -.sub 'callwith' - .param pmc pos_args :slurpy - .param pmc named_args :slurpy :named - - # For callwith, it's easy - just want to get the next candidate, call - # it and hand back it's return values. A tailcall does fine. - .local pmc clist, lexpad, self, next - get_next_candidate_info clist, $P0, lexpad - next = clone clist - next.'set_failure_mode'() - $P0 = deref next - $I0 = isa $P0, 'Method' - unless $I0 goto not_method - self = lexpad['self'] - .tailcall next(self, pos_args :flat, named_args :flat :named) - not_method: - .tailcall next(pos_args :flat, named_args :flat :named) -.end - - -=item nextwith - -=cut - -.sub 'nextwith' - .param pmc pos_args :slurpy - .param pmc named_args :slurpy :named - - # Find next candiate, invoke it and get its return value, then use - # return to return it as if it was from our original call. - .local pmc clist, lexpad, self, next, result - get_next_candidate_info clist, $P0, lexpad - next = clone clist - next.'set_failure_mode'() - $P0 = deref next - $I0 = isa $P0, 'Method' - unless $I0 goto not_method - self = lexpad['self'] - (result) = next(self, pos_args :flat, named_args :flat :named) - goto process_result - not_method: - (result) = next(pos_args :flat, named_args :flat :named) - - process_result: - $I0 = isa result, ['Failure'] - unless $I0 goto did_defer - $P0 = getattribute result, '$!exception' - if null $P0 goto did_defer - $S0 = $P0['message'] - if $S0 != 'No method to defer to' goto did_defer - .return (result) - - did_defer: - 'return'(result) -.end - - -=item callsame - -=cut - -.sub 'callsame' - # Find next candidate as well as caller and lexpad. - .local pmc clist, routine, lexpad, next - get_next_candidate_info clist, routine, lexpad - next = clone clist - - # Build arguments based upon what the caller was originall invoked with, - # and tailcall the next candidate. - .local pmc pos_args, named_args - $P1 = lexpad['call_sig'] - (pos_args, named_args) = '!deconstruct_call_sig'($P1) - next.'set_failure_mode'() - .tailcall next(pos_args :flat, named_args :flat :named) -.end - - -=item nextsame - -=cut - -.sub 'nextsame' - # Find next candidate as well as caller and lexpad. - .local pmc clist, routine, lexpad, next - get_next_candidate_info clist, routine, lexpad - next = clone clist - - # Build arguments based upon what the caller was originall invoked with, - # get the result of the next candidate and use return to retrun from - # the caller, provided the defer did not fail. - .local pmc pos_args, named_args, result - $P1 = lexpad['call_sig'] - (pos_args, named_args) = '!deconstruct_call_sig'($P1) - next.'set_failure_mode'() - (result) = next(pos_args :flat, named_args :flat :named) - - $I0 = isa result, ['Failure'] - unless $I0 goto did_defer - $P0 = getattribute result, '$!exception' - if null $P0 goto did_defer - $S0 = $P0['message'] - if $S0 != 'No method to defer to' goto did_defer - .return (result) - - did_defer: - 'return'(result) -.end - - -=item lastcall - -Trims the candidate list so that nextsame/nextwith/callsame/callwith will -find nothing more to call. - -=cut - -.sub 'lastcall' - # Find candidate list and trim it. - .local pmc clist - get_next_candidate_info clist, $P0, $P1 - clist.'trim_candidate_list'() -.end - - -=back - -=head1 TODO: Functions - -=over 4 - -=item evalfile - - multi Control::Basic::evalfile (Str $filename : Grammar :$lang = Perl6) - -Behaves like, and replaces Perl 5 C, with optional C<$lang> -support. - - -=item fail - -B: Research the exception handling system. - -=item warn - -B: Throw a resumable exception when Rakudo supports top-level exception -handlers. Note that the default exception handler should print the message of -this exception to standard error. - - -=back - -=cut - -# Local Variables: -# mode: pir -# fill-column: 100 -# End: -# vim: expandtab shiftwidth=4 ft=pir: diff --git a/src/old/builtins-old/eval.pir b/src/old/builtins-old/eval.pir deleted file mode 100644 index d28dbb0b655..00000000000 --- a/src/old/builtins-old/eval.pir +++ /dev/null @@ -1,276 +0,0 @@ -## $Id$ - -=head1 NAME - -src/builtins/eval.pir - Perl6 evaluators - -=head1 DESCRIPTION - -This file implements methods and functions that evaluate code, -such as C, C, and C. The function C -itself can be found in src/builtins/control.pir. - -=head1 Methods - -=over 4 - -=cut - -.namespace [] -.sub 'onload' :anon :init :load - $P0 = get_hll_namespace ['Any'] - '!EXPORT'('evalfile', 'from'=>$P0) -.end - - -.namespace ['Any'] -.sub 'evalfile' :method :multi(_) - .param pmc options :slurpy :named - - .local string filename - filename = self - - .local string lang - lang = options['lang'] - if lang == 'Parrot' goto lang_parrot - if lang goto lang_compile - lang = 'perl6' - lang_compile: - .local pmc compiler - compiler = compreg lang - # XXX FIXME: We should allow the compiler to choose default encoding/transcode - .tailcall compiler.'evalfiles'(filename, 'encoding'=>'utf8', 'transcode'=>'ascii iso-8859-1') - - lang_parrot: - ## load_bytecode currently doesn't accept non-ascii filenames (TT #65) - ## so we'll force it to ascii for now. - $I0 = find_charset 'ascii' - filename = trans_charset filename, $I0 - load_bytecode filename - .return (1) -.end - - -.namespace [] -.sub 'require' :multi(_) - .param string name - .param pmc options :named :slurpy - - # Save current begin_compunit flag for restoration later. - .local pmc begin_compunit - begin_compunit = get_global '$begin_compunit' - - .local int ismodule - .local pmc module - ismodule = 0 - module = options['module'] - if null module goto have_name - ismodule = istrue module - unless ismodule goto have_name - - ## convert '::' to '/' - name = clone name - slash_convert: - $I0 = index name, '::' - if $I0 < 0 goto have_name - substr name, $I0, 2, '/' - goto slash_convert - - have_name: - ## see if we loaded this already - .local pmc inc_hash - inc_hash = '!find_contextual'('%*INC') - $I0 = exists inc_hash[name] - unless $I0 goto require_name - $I0 = defined inc_hash[name] - .return ($I0) - - require_name: - ## loop through @INC - .local pmc inc_it - $P0 = '!find_contextual'('@*INC') - inc_it = iter $P0 - inc_loop: - unless inc_it goto inc_end - .local string basename, realfilename - $S0 = shift inc_it - basename = concat $S0, '/' - basename .= name - if ismodule goto try_module - realfilename = basename - $I0 = stat realfilename, 0 - if $I0 goto eval_perl6 - goto inc_loop - try_module: - realfilename = concat basename, '.pbc' - $I0 = stat realfilename, 0 - if $I0 goto eval_parrot - realfilename = concat basename, '.pir' - $I0 = stat realfilename, 0 - if $I0 goto eval_parrot - realfilename = concat basename, '.pm' - $I0 = stat realfilename, 0 - if $I0 goto eval_perl6 - goto inc_loop - inc_end: - $S0 = concat "Can't find ", basename - concat $S0, ' in @*INC' - 'die'($S0) - .return (0) - - eval_parrot: - .local pmc result - inc_hash[name] = realfilename - result = 'evalfile'(realfilename, 'lang'=>'Parrot') - goto done - - eval_perl6: - .local pmc outer_ns_chain, outer_blocks - outer_ns_chain = get_hll_global ['Perl6';'Grammar';'Actions'], '@?NS' - outer_blocks = get_hll_global ['Perl6';'Grammar';'Actions'], '@?BLOCK' - $P0 = new ['List'] - set_hll_global ['Perl6';'Grammar';'Actions'], '@?NS', $P0 - $P0 = new ['List'] - set_hll_global ['Perl6';'Grammar';'Actions'], '@?BLOCK', $P0 - inc_hash[name] = realfilename - result = 'evalfile'(realfilename, 'lang'=>'perl6') - set_hll_global ['Perl6';'Grammar';'Actions'], '@?NS', outer_ns_chain - set_hll_global ['Perl6';'Grammar';'Actions'], '@?BLOCK', outer_blocks - - done: - set_global '$begin_compunit', begin_compunit - .return (result) -.end - - -.sub 'use' - .param string module - .param pmc args :slurpy - .param pmc options :slurpy :named - - .local pmc ver, compiler_obj - .local string lang - compiler_obj = compreg 'perl6' - - # This HLL stuff *should* be integrated with the rest... I spent an hour on it and failed. - ver = options['ver'] - if null ver goto no_hll - $P0 = ver['from'] - if null $P0 goto no_hll - lang = $P0 - .local pmc name, compiler, library, imports, callerns, foreignlibns - $P0 = getinterp - callerns = $P0['namespace';1] - 'load-language'(lang) - compiler = compreg lang - name = compiler_obj.'parse_name'(module) - library = compiler.'load_library'(name) - imports = library['symbols'] - imports = imports['DEFAULT'] - .local pmc ns_iter, item - ns_iter = iter imports - import_loop: - unless ns_iter goto import_loop_end - $S0 = shift ns_iter - $P0 = imports[$S0] - callerns[$S0] = $P0 - goto import_loop - import_loop_end: - foreignlibns = library['namespace'] - if null foreignlibns goto no_foreign_ns - $S0 = pop name - set_hll_global name, $S0, foreignlibns - no_foreign_ns: - .return (library) - no_hll: - # Require module. - .local pmc retval - retval = 'require'(module, 'module'=>1, 'ver'=>ver) - unless null retval goto have_retval - retval = '!FAIL'() - have_retval: - - # This is a first cut of import. It's essentially wrong, since it's meant - # by default to put stuff into the lexical pad rather than the namespace. - # However, it works as a first cut, and lexical stuff isn't quite there - # enough in Rakudo yet. - - # See if we've had a namespace name passed in. - .local pmc import_ns - $P0 = options['import_to'] - if null $P0 goto use_caller_ns - $S0 = $P0 - if $S0 == "" goto use_hll_root_ns - $P1 = compiler_obj.'parse_name'($S0) - $S0 = pop $P1 - import_ns = get_hll_global $P1, $S0 - goto got_import_ns - use_hll_root_ns: - import_ns = get_hll_namespace - goto got_import_ns - use_caller_ns: - $P0 = getinterp - $P0 = $P0['sub'; 1] - import_ns = $P0.'get_namespace'() - got_import_ns: - - # Get list of symbols to import. - .local pmc tag_hash, tags - tag_hash = options['tags'] - tags = root_new ['parrot';'ResizableStringArray'] - if null tag_hash goto default_tag - $P0 = iter tag_hash - th_it_loop: - unless $P0 goto have_tags - $S0 = shift $P0 - push tags, $S0 - goto th_it_loop - default_tag: - push tags, 'DEFAULT' - have_tags: - - # Always need to import MANDATORY stuff. - push tags, 'MANDATORY' - - # Look up symbols to import and import them by tag. - .local pmc export_ns, export_root_nsarray, tag_it - export_root_nsarray = compiler_obj.'parse_name'(module) - push export_root_nsarray, 'EXPORT' - tag_it = iter tags - tag_it_loop: - - # Find symbols to be imported from this tag. - unless tag_it goto tag_it_loop_end - $S0 = shift tag_it - export_ns = get_hll_global export_root_nsarray, $S0 - if null export_ns goto tag_it_loop - - # Iterate over them and import. - .local pmc it - it = iter export_ns - it_loop: - unless it goto it_loop_end - $S0 = shift it - $P0 = export_ns[$S0] - import_ns[$S0] = $P0 - goto it_loop - it_loop_end: - - goto tag_it_loop - tag_it_loop_end: - - done_import: - .return (retval) -.end - - -=back - -=cut - -# Local Variables: -# mode: pir -# fill-column: 100 -# End: -# vim: expandtab shiftwidth=4 ft=pir: - diff --git a/src/old/builtins-old/globals.pir b/src/old/builtins-old/globals.pir deleted file mode 100644 index a28f27ddf48..00000000000 --- a/src/old/builtins-old/globals.pir +++ /dev/null @@ -1,183 +0,0 @@ -## $Id$ - -=head1 NAME - -src/builtins/globals.pir - initialize miscellaneous global variables - -=cut - -.namespace [] - - -.include 'interpinfo.pasm' -.include 'sysinfo.pasm' - - -.sub 'onload' :anon :load :init - .local pmc p6meta - p6meta = get_hll_global ['Perl6Object'], '$!P6META' - - ## set up %*ENV - .local pmc env - env = '!env_to_hash'() - set_hll_global ['PROCESS'], '%ENV', env - - ## set up $*OS, $*OSVER $*EXECUTABLE_NAME - .local string info - info = sysinfo .SYSINFO_PARROT_OS - $P0 = new ['Str'] - $P0 = info - set_hll_global ['PROCESS'], '$OS', $P0 - - info = sysinfo .SYSINFO_PARROT_OS_VERSION - $P0 = new ['Str'] - $P0 = info - set_hll_global ['PROCESS'], '$OSVER', $P0 - - info = interpinfo .INTERPINFO_EXECUTABLE_FULLNAME - $P0 = new ['Str'] - $P0 = info - set_hll_global ['PROCESS'], '$EXECUTABLE_NAME', $P0 - - ## create basic $*CWD - .local pmc os - os = root_new ['parrot';'OS'] - $S0 = os."cwd"() - $P0 = box $S0 - set_hll_global '$CWD', $P0 - - ## create $*IN, $*OUT, $*ERR filehandles - .local pmc pio, perl6io, perl6ioclass - perl6ioclass = get_hll_global "IO" - pio = getstdin - pio.'encoding'('utf8') - perl6io = perl6ioclass.'new'("PIO" => pio) - set_hll_global ['PROCESS'], "$IN", perl6io - pio = getstdout - pio.'encoding'('utf8') - perl6io = perl6ioclass.'new'("PIO" => pio) - set_hll_global ['PROCESS'], "$OUT", perl6io - pio = getstderr - pio.'encoding'('utf8') - perl6io = perl6ioclass.'new'("PIO" => pio) - set_hll_global ['PROCESS'], "$ERR", perl6io - - ## set up %*VM - load_bytecode 'config.pbc' - .include 'iglobals.pasm' - .local pmc vm, interp, config - vm = new ['Perl6Hash'] - interp = getinterp - config = interp[.IGLOBALS_CONFIG_HASH] - config = new ['Perl6Scalar'], config - vm['config'] = config - set_hll_global ['PROCESS'], "%VM", vm - - ## set up @*INC - $S0 = env['PERL6LIB'] - $P0 = split ':', $S0 - config = interp[.IGLOBALS_CONFIG_HASH] - $S0 = config['libdir'] - $S1 = config['versiondir'] - concat $S0, $S1 - concat $S0, '/languages/perl6/lib' - unshift $P0, $S0 - $S0 = env['HOME'] - if $S0 goto have_home - $S0 = env['HOMEDRIVE'] - $S1 = env['HOMEPATH'] - concat $S0, $S1 - have_home: - concat $S0, '/.perl6/lib' - unshift $P0, $S0 - push $P0, '.' - $P0 = 'list'($P0) - $P0 = $P0.'Array'() - set_hll_global ['PROCESS'], '@INC', $P0 - - ## set up %*INC - $P0 = new ['Perl6Hash'] - set_hll_global ['PROCESS'], '%INC', $P0 - - ## the default value for new ObjectRefs - $P0 = 'undef'() - set_hll_global '$!OBJECTREF', $P0 -.end - - -.namespace [] -.sub '!find_contextual' - .param string name - - # first search caller scopes - $P0 = find_dynamic_lex name - unless null $P0 goto done - - # next, strip twigil and search PROCESS package - .local string pkgname - pkgname = clone name - substr pkgname, 1, 1, '' - $P0 = get_hll_global ['PROCESS'], pkgname - unless null $P0 goto done - $P0 = get_global pkgname - unless null $P0 goto done - - fail: - $P0 = '!FAIL'('Contextual ', name, ' not found') - done: - .return ($P0) -.end - - -.sub '!env_to_hash' - .local pmc env, hash - env = root_new ['parrot';'Env'] - hash = new ['Perl6Hash'] - $P0 = iter env - env_loop: - unless $P0 goto env_done - $S0 = shift $P0 - $S1 = env[$S0] - hash[$S0] = $S1 - goto env_loop - env_done: - .return (hash) -.end - - -.sub '!hash_to_env' - .param pmc hash :optional - .param int has_hash :opt_flag - - if has_hash goto have_hash - hash = '!find_contextual'('%*ENV') - have_hash: - - .local pmc env - env = root_new ['parrot';'Env'] - $P0 = iter env - env_loop: - unless $P0 goto env_done - $S0 = shift $P0 - $I0 = exists hash[$S0] - if $I0 goto env_loop - delete env[$S0] - goto env_loop - env_done: - - $P0 = iter hash - hash_loop: - unless $P0 goto hash_done - $S0 = shift $P0 - $S1 = hash[$S0] - env[$S0] = $S1 - goto hash_loop - hash_done: -.end - -# Local Variables: -# mode: pir -# fill-column: 100 -# End: -# vim: expandtab shiftwidth=4 ft=pir: - diff --git a/src/old/builtins-old/guts.pir b/src/old/builtins-old/guts.pir deleted file mode 100644 index b1cf65452d3..00000000000 --- a/src/old/builtins-old/guts.pir +++ /dev/null @@ -1,1515 +0,0 @@ -## $Id$ - -=head1 NAME - -src/builtins/guts.pir - subs that are part of the internals, not for users - -=head1 SUBS - -=over 4 - -=item !EXPORT(symbols, from :named('from') [, to :named('to')] ) - -Export symbols in namespace C to the namespace given by C. -If C isn't given, then exports into the HLL global namespace. -This function differs somewhat from Parrot's C PMC in that -it understands how to properly merge C PMCs. - -=cut - -.namespace [] -.sub '!EXPORT' - .param string symbols - .param pmc from :named('from') - .param pmc to :named('to') :optional - .param int has_to :opt_flag - .param int to_p6_multi :named('to_p6_multi') :optional - - if has_to goto have_to - to = get_hll_namespace - have_to: - - .local pmc list - list = split ',', symbols - list_loop: - unless list goto list_end - .local string symbol - .local pmc value - symbol = shift list - value = from[symbol] - $I0 = isa value, 'MultiSub' - unless $I0 goto store_value - if to_p6_multi != 1 goto no_convert - $P0 = value[0] - '!TOPERL6MULTISUB'($P0) - value = from[symbol] - no_convert: - $P0 = to[symbol] - if null $P0 goto store_value - $I0 = isa $P0, 'MultiSub' - unless $I0 goto err_type_conflict - $I0 = elements $P0 - splice $P0, value, $I0, 0 - goto list_loop - store_value: - to[symbol] = value - goto list_loop - list_end: - .return () - - err_type_conflict: - $S0 = concat "Unable to add Multisub '", symbol - $S0 .= "' to existing value" - die $S0 -.end - - -=item !CALLMETHOD('method', obj) - -Invoke a method on a possibly foreign object. If the object -supports the requested method, we use it, otherwise we assume -the object is foreign and try using the corresponding method -from C. - -=cut - -.namespace [] -.sub '!CALLMETHOD' - .param string method - .param pmc obj - $I0 = isa obj, 'Perl6Scalar' - if $I0 goto any_method - $I0 = can obj, method - unless $I0 goto any_method - .tailcall obj.method() - any_method: - .local pmc anyobj - anyobj = get_global '$!ANY' - unless null anyobj goto any_method_1 - anyobj = new ['Any'] - set_global '$!ANY', anyobj - any_method_1: - $P0 = find_method anyobj, method - .tailcall obj.$P0() -.end - - -=item !dispatch_method_indirect - -Does an indirect method dispatch. - -=cut - -.sub '!dispatch_method_indirect' - .param pmc obj - .param pmc methodish - .param pmc pos_args :slurpy - .param pmc name_args :slurpy :named - - $I0 = isa methodish, 'P6Invocation' - if $I0 goto ready_to_dispatch - $P0 = get_hll_global 'Callable' - $I0 = $P0.'ACCEPTS'(methodish) - unless $I0 goto candidate_list - ready_to_dispatch: - .tailcall methodish(obj, pos_args :flat, name_args :flat :named) - - candidate_list: - $P0 = root_new ['parrot';'P6Invocation'], methodish - .tailcall $P0(obj, pos_args :flat, name_args :flat :named) -.end - - -=item !dispatch_dispatcher_parallel - -Does a parallel method dispatch over an existing dispatcher. Just invokes the normal -dispatcher for each thingy we're dispatching over. - -=cut - -.sub '!dispatch_dispatcher_parallel' - .param pmc invocanty - .param string dispatcher - .param pmc pos_args :slurpy - .param pmc named_args :slurpy :named - - .local pmc it, result, disp - disp = find_name dispatcher - result = new ['Perl6Array'] - invocanty = invocanty.'list'() - it = iter invocanty - it_loop: - unless it goto it_loop_done - $P0 = shift it - $P0 = disp($P0, pos_args :flat, named_args :flat :named) - $P0 = $P0.'Scalar'() - result.'push'($P0) - goto it_loop - it_loop_done: - - .return (result) -.end - - -=item !dispatch_method_parallel - -Does a parallel method dispatch. Invokes the method for each thing in the -array of invocants. - -=cut - -.sub '!dispatch_method_parallel' - .param pmc invocanty - .param string name - .param pmc pos_args :slurpy - .param pmc named_args :slurpy :named - - .local pmc it, result - result = new ['Perl6Array'] - invocanty = invocanty.'list'() - it = iter invocanty - it_loop: - unless it goto it_loop_done - $P0 = shift it - $P0 = $P0.name(pos_args :flat, named_args :flat :named) - $P0 = $P0.'Scalar'() - result.'push'($P0) - goto it_loop - it_loop_done: - - .return (result) -.end - - -=item !VAR - -Helper function for implementing the VAR and .VAR macros. - -=cut - -.sub '!VAR' - .param pmc variable - $I0 = isa variable, 'Perl6Scalar' - unless $I0 goto nothing - $P0 = root_new ['parrot';'MutableVAR'], variable - .return ($P0) - nothing: - .return (variable) -.end - - - -=item !CREATE_SUBSET_TYPE - -Creates a subset type. Basically, we make an anonymous subclass of the -original type, attach the refinement and override ACCEPTS. We also chase up -to find a real, non-subtype and stash that away for fast access later. - -=cut - -.sub '!CREATE_SUBSET_TYPE' - .param pmc refinee - .param pmc refinement - - .local pmc p6meta - p6meta = get_hll_global ['Perl6Object'], '$!P6META' - - # Check if the refinee is a refinement type itself; if so, get the real - # base type we're refining. - .local pmc real_type, real_type_pc - real_type = getprop 'subtype_realtype', refinee - unless null $P0 goto got_real_type - real_type = refinee - got_real_type: - - # Create subclass. If it's a role, pun it. - .local pmc parrot_class, type_obj, subset - type_obj = refinee - $I0 = isa type_obj, 'Perl6Role' - unless $I0 goto ambig_role_done - type_obj = type_obj.'!select'() - ambig_role_done: - $I0 = isa type_obj, 'P6role' - unless $I0 goto role_done - type_obj = type_obj.'!pun'() - role_done: - parrot_class = p6meta.'get_parrotclass'(type_obj) - subset = subclass parrot_class - - # Override accepts. - .local pmc parrotclass - .const 'Sub' $P0 = "!SUBTYPE_ACCEPTS" - subset.'add_method'('ACCEPTS', $P0) - .const 'Sub' $P1 = "!SUBTYPE_PROTOOVERRIDES" - subset.'add_method'('PROTOOVERRIDES', $P1) - - # It's an abstraction. - $P0 = get_hll_global 'Abstraction' - $P0 = $P0.'!select'() - subset.'add_role'($P0) - - # Register it, creating a proto-object. - subset = p6meta.'register'(subset) - - # Mark it a subtype and stash away real type, refinee and refinement. - $I0 = isa real_type, 'Perl6Role' - unless $I0 goto real_type_done - real_type = real_type.'!select'() - real_type_done: - setprop subset, 'subtype_realtype', real_type - setprop subset, 'subtype_refinement', refinement - setprop subset, 'subtype_refinee', refinee - - .return (subset) -.end -.sub "!SUBTYPE_ACCEPTS" :anon :method - .param pmc topic - - # Get refinement and check against that. - .local pmc refinement - refinement = getprop 'subtype_refinement', self - $P0 = refinement(topic) - unless $P0 goto false - - # Recurse up the tree. - .local pmc refinee - refinee = getprop 'subtype_refinee', self - $P0 = refinee.'ACCEPTS'(topic) - unless $P0 goto false - - true: - $P0 = get_hll_global ['Bool'], 'True' - .return ($P0) - false: - $P0 = get_hll_global ['Bool'], 'False' - .return ($P0) -.end -.sub '!SUBTYPE_PROTOOVERRIDES' :anon :method - .return ('new', 'ACCEPTS') -.end - - -=item !TOPERL6MULTISUB - -At the moment, we don't have the abilility to have Parrot use our own MultiSub -type, nor are we ready to (because built-ins need to get Perl 6 signatures -first). So for now we just transform multis in user code like this. - -=cut - -.sub '!TOPERL6MULTISUB' - .param pmc sub - - # Look up what's currently installed in the namespace for this sub; if it - # is already a Perl6MultiSub, leave it. - .local pmc namespace, current_thing - .local string name - namespace = sub.'get_namespace'() - name = sub - current_thing = namespace[name] - if null current_thing goto error - $S0 = typeof current_thing - if $S0 == 'MultiSub' goto not_perl6_multisub - .return() - # It's not a Perl6MultiSub, create one and put contents into it. - not_perl6_multisub: - .local pmc p6multi, sub_iter - p6multi = root_new ['parrot';'Perl6MultiSub'] - sub_iter = iter current_thing - iter_loop: - unless sub_iter goto iter_loop_end - $P0 = shift sub_iter - push p6multi, $P0 - goto iter_loop - iter_loop_end: - - # Nor replace the current thing with the new data structure. - copy current_thing, p6multi - .return() - - error: - 'die'('Sub lookup failed') -.end - - -=item !clone_multi_for_lexical - -=cut - -.sub '!clone_multi_for_lexical' - .param pmc existing - if null existing goto fresh - unless existing goto fresh - $P0 = existing.'clone'() - .return ($P0) - fresh: - $P0 = root_new ['parrot';'Perl6MultiSub'] - .return ($P0) -.end - - -=item !UNIT_START - -=cut - -.sub '!UNIT_START' - .param pmc unitmain - .param pmc args - - args = 'list'(args) - if args goto start_main - .tailcall unitmain() - - start_main: - ## We're running as main program - ## Remove program argument (0) and put it in $*PROGRAM_NAME, then set up - ## @ARGS global. - $P0 = shift args - set_hll_global '$PROGRAM_NAME', $P0 - args = args.'Array'() - set_hll_global '@ARGS', args - ## run unitmain - .local pmc result, MAIN - result = unitmain() - ## if there's a MAIN sub in unitmain's namespace, run it also - $P0 = unitmain.'get_namespace'() - MAIN = $P0['MAIN'] - if null MAIN goto done - args = get_hll_global '@ARGS' - result = MAIN(args :flat) - done: - .return (result) -.end - - -=item !capture - -Combine slurpy positional and slurpy named args into a list. -Note that original order may be lost -- that's the nature -of captures. - -=cut - -.sub '!capture' - .param pmc args :slurpy - .param pmc options :slurpy :named - unless options goto done - .local pmc it - it = iter options - iter_loop: - unless it goto done - $S0 = shift it - $P0 = options[$S0] - $P0 = 'infix:=>'($S0, $P0) - push args, $P0 - goto iter_loop - done: - .tailcall args.'list'() -.end - - -=item !ADDTOROLE - -Adds a given role initializing multi-variant to a Role object, creating it -and putting it in the namespace if it doesn't already exist. - -=cut - -.sub '!ADDTOROLE' - .param pmc variant - - # Get short name of role. - .local pmc ns - .local string short_name - ns = variant.'get_namespace'() - ns = ns.'get_name'() - short_name = pop ns - $P0 = box short_name - setprop variant, "$!shortname", $P0 - $I0 = index short_name, '[' - if $I0 == -1 goto have_short_name - short_name = substr short_name, 0, $I0 - have_short_name: - - # See if we have a Role object already. - .local pmc role_obj - role_obj = get_root_global ns, short_name - if null role_obj goto need_role_obj - $I0 = isa role_obj, 'NameSpace' - unless $I0 goto have_role_obj - need_role_obj: - role_obj = new ['Perl6Role'] - transform_to_p6opaque role_obj - set_root_global ns, short_name, role_obj - $P0 = box short_name - setattribute role_obj, "$!shortname", $P0 - have_role_obj: - - # Add this variant. - role_obj.'!add_variant'(variant) -.end - - -=item !meta_create(type, name, also) - -Create a metaclass object for C with the given C. -This simply creates a handle on which we can hang methods, attributes, -traits, etc. -- the class itself isn't created until the class -is composed (see C below). - -=cut - -.sub '!meta_create' - .param string type - .param string name - .param int also - - .local pmc nsarray - $P0 = get_hll_global [ 'Perl6';'Compiler' ], 'parse_name' - $P1 = null - nsarray = $P0($P1, name) - - if type == 'package' goto package - if type == 'module' goto package - if type == 'class' goto class - if type == 'grammar' goto class - if type == 'role' goto role - 'die'("Unsupported package declarator ", type) - - package: - $P0 = get_hll_namespace nsarray - .return ($P0) - - class: - .local pmc parrotclass, metaclass, ns - ns = get_hll_namespace nsarray - if also goto is_also - parrotclass = newclass ns - $P0 = box type - setprop parrotclass, 'pkgtype', $P0 - '!set_resolves_list'(parrotclass) - metaclass = new ['ClassHOW'] - setattribute metaclass, 'parrotclass', parrotclass - .return (metaclass) - is_also: - parrotclass = get_class ns - metaclass = getprop 'metaclass', parrotclass - .return (metaclass) - - role: - # This is a little fun. We only want to create the Parrot role and suck - # in the methods once per role definition. We do this and it is attached to - # the namespace. Then we attach this "master role" to a new one we create - # per invocation, so the methods can be newclosure'd and added into it in - # the body. - .local pmc info, parrotrole - ns = get_hll_namespace nsarray - parrotrole = get_class ns - unless null parrotrole goto have_role - - info = root_new ['parrot';'Hash'] - $P0 = nsarray[-1] - info['name'] = $P0 - info['namespace'] = nsarray - parrotrole = root_new ['parrot';'P6role'], info - have_role: - - # Copy list of roles done by the original role into this specific - # one. - .local pmc specific_role, tmp, it - specific_role = root_new ['parrot';'P6role'] - setprop specific_role, '$!orig_role', parrotrole - tmp = parrotrole.'roles'() - it = iter tmp - roles_loop: - unless it goto roles_loop_end - tmp = shift it - specific_role.'add_role'(tmp) - goto roles_loop - roles_loop_end: - - # Now create a meta-object (RoleHOW) to package this all up in. - .local pmc metaclass - metaclass = new ['RoleHOW'] - setprop specific_role, 'metaclass', metaclass - setattribute metaclass, 'parrotclass', specific_role - setattribute metaclass, 'protoobject', specific_role - setattribute metaclass, 'shortname', $P0 - $P1 = box name - setattribute metaclass, 'longname', $P1 - .return (metaclass) -.end - - -=item !meta_compose(Class metaclass) - -Compose the class. This includes resolving any inconsistencies -and creating the protoobjects. - -=cut - -.sub '!meta_compose' - .param pmc metaclass - .local pmc p6meta - p6meta = get_hll_global ['Perl6Object'], '$!P6META' - - # If it's a RoleHOW or otherwise just not a ClassHOW, nothing to do. - $I0 = isa metaclass, 'RoleHOW' - if $I0 goto no_pkgtype - $I0 = isa metaclass, 'ClassHOW' - unless $I0 goto no_pkgtype - - # Extract the parrotclass form the metaclass. - .local pmc parrotclass - parrotclass = getattribute metaclass, 'parrotclass' - - # Parrot handles composing methods into roles, but we need to handle the - # attribute composition ourselves. - .local pmc roles, roles_it - roles = getprop '@!roles', parrotclass - if null roles goto roles_it_loop_end - roles = '!get_flattened_roles_list'(roles) - roles_it = iter roles - roles_it_loop: - unless roles_it goto roles_it_loop_end - $P0 = shift roles_it - $I0 = does parrotclass, $P0 - if $I0 goto roles_it_loop - parrotclass.'add_role'($P0) - '!compose_role_attributes'(parrotclass, $P0) - goto roles_it_loop - roles_it_loop_end: - - # We may need to set up invoke vtable if postcircumfix:<( )> - # is implemented. - '!setup_invoke_vtable'(metaclass) - - # Create proto-object with default parent being Any or Grammar, unless - # there already is a parent. - .local pmc proto - $P0 = parrotclass.'parents'() - $I0 = elements $P0 - if $I0 goto register_parent_set - $S0 = 'Any' - $P0 = getprop 'pkgtype', parrotclass - if null $P0 goto no_pkgtype - if $P0 != 'grammar' goto register - $S0 = 'Grammar' - register: - proto = p6meta.'register'(parrotclass, 'parent'=>$S0, 'how'=>metaclass) - goto have_proto - register_parent_set: - proto = p6meta.'register'(parrotclass, 'how'=>metaclass) - have_proto: - transform_to_p6opaque proto - .return (proto) - no_pkgtype: - .return (metaclass) -.end - - -=item !setup_invoke_vtable - -If we override postcircumfix:<( )> then also add a -vtable override for invoke. - -=cut - -.sub '!setup_invoke_vtable' - .param pmc metaclass - .local pmc parrotclass - parrotclass = getattribute metaclass, 'parrotclass' - $P0 = parrotclass.'methods'() - $P0 = $P0['postcircumfix:( )'] - if null $P0 goto no_invoke - .const 'Sub' $P1 = '!invoke_vtable_override_helper' - parrotclass.'add_vtable_override'('invoke', $P1) - no_invoke: -.end -.sub '' :subid('!invoke_vtable_override_helper') - .param pmc pos_args :slurpy - .param pmc named_args :slurpy :named - $P0 = getinterp - $P0 = $P0['sub'] - $P0 = getprop '$!self', $P0 - .tailcall $P0.'postcircumfix:( )'(pos_args :flat, named_args :flat :named) -.end - - -=item !get_flattened_roles_list - -Flattens out the list of roles. - -=cut - -.sub '!get_flattened_roles_list' - .param pmc unflat_list - .local pmc flat_list, it, cur_role, nested_roles, nested_it - flat_list = root_new ['parrot';'ResizablePMCArray'] - it = iter unflat_list - it_loop: - unless it goto it_loop_end - cur_role = shift it - $I0 = isa cur_role, 'Role' - unless $I0 goto error_not_a_role - push flat_list, cur_role - nested_roles = getprop '@!roles', cur_role - if null nested_roles goto it_loop - nested_roles = '!get_flattened_roles_list'(nested_roles) - nested_it = iter nested_roles - nested_it_loop: - unless nested_it goto it_loop - $P0 = shift nested_it - push flat_list, $P0 - goto nested_it_loop - it_loop_end: - .return (flat_list) - error_not_a_role: - 'die'('Can not compose a non-role.') -.end - - -=item !meta_attribute(metaclass, name, itypename [, 'type'=>type] ) - -Add attribute C to C with the given C -and C. - -=cut - -.sub '!meta_attribute' - .param pmc metaclass - .param string name - .param string itypename :optional - .param int has_itypename :opt_flag - .param pmc attr :slurpy :named - - # twigil handling (for has &!foo, we just get name as !foo) - .local int offset - .local string twigil - offset = 1 - $S0 = substr name, 0, 1 - if $S0 != '!' goto offset_done - offset = 0 - offset_done: - twigil = substr name, offset, 1 - if twigil == '.' goto twigil_public - if twigil == '!' goto twigil_done - substr name, offset, 0, '!' - goto twigil_done - twigil_public: - substr name, offset, 1, '!' - twigil_done: - - # In the future, we'll want to have just called metaclass.add_attribute(...) - # here and let it handle all of this, but we ain't quite ready for that yet. - $I0 = isa metaclass, 'P6metaclass' - unless $I0 goto got_parrot_class - metaclass = getattribute metaclass, 'parrotclass' - got_parrot_class: - - $P0 = metaclass.'attributes'() - $I0 = exists $P0[name] - if $I0 goto attr_exists - addattribute metaclass, name - $P1 = getprop '@!attribute_list', metaclass - unless null $P1 goto have_attrlist - $P1 = root_new ['parrot';'ResizableStringArray'] - setprop metaclass, '@!attribute_list', $P1 - have_attrlist: - push $P1, name - $P0 = metaclass.'attributes'() - attr_exists: - - .local pmc attrhash, it - attrhash = $P0[name] - - # Set any itype for the attribute. - unless has_itypename goto itype_done - .local pmc itype - if itypename == 'Perl6Scalar' goto itype_pmc - itype = get_class itypename - goto have_itype - itype_pmc: - $P0 = get_root_namespace ['parrot';'Perl6Scalar'] - itype = get_class $P0 - have_itype: - attrhash['itype'] = itype - itype_done: - - # and set any other attributes that came in via the slurpy hash - it = iter attr - attr_loop: - unless it goto attr_done - $S0 = shift it - $P0 = attr[$S0] - attrhash[$S0] = $P0 - goto attr_loop - attr_done: - - # Anything to do with handles? - $P0 = attr['handles'] - if null $P0 goto handles_done - - # For the handles trait verb, we may have got a name or a list of names. - # If so, just generate methods with those names. Otherwise, need to store - # them as a property on the metaclass, so the dispatcher can smart-match - # against them later. - .const 'Sub' handles = '!handles' - .local pmc handles_it - $I0 = isa $P0, 'Str' - if $I0 goto simple_handles - $I0 = isa $P0, 'List' - if $I0 goto simple_handles - $I0 = isa $P0, 'Perl6Pair' - if $I0 goto simple_handles - - .local pmc class_handles_list, handles_hash - class_handles_list = getprop '@!handles_dispatchers', metaclass - unless null class_handles_list goto have_class_handles_list - class_handles_list = root_new ['parrot';'ResizablePMCArray'] - setprop metaclass, '@!handles_dispatchers', class_handles_list - have_class_handles_list: - handles_hash = root_new ['parrot';'Hash'] - handles_hash['attrname'] = name - handles_hash['match_against'] = $P0 - push class_handles_list, handles_hash - goto handles_done - - simple_handles: - $P0 = 'list'($P0) - handles_it = iter $P0 - handles_loop: - .local string visible_name - .local pmc orig_name - unless handles_it goto handles_done - $P0 = clone handles - $P1 = box name - setprop $P0, 'attrname', $P1 - $P1 = shift handles_it - $I0 = isa $P1, 'Perl6Pair' - if $I0 goto handles_pair - visible_name = $P1 - orig_name = $P1 - goto naming_done - handles_pair: - visible_name = $P1.'key'() - orig_name = $P1.'value'() - naming_done: - setprop $P0, 'methodname', orig_name - metaclass.'add_method'(visible_name, $P0) - goto handles_loop - handles_done: - .return () -.end - - -.sub '!handles' :method - .param pmc args :slurpy - .param pmc options :slurpy :named - .local pmc method, attribute - .local string attrname - $P0 = getinterp - method = $P0['sub'] - $P1 = getprop 'attrname', method - attrname = $P1 - attribute = getattribute self, attrname - $P1 = getprop 'methodname', method - $S1 = $P1 - .tailcall attribute.$S1(args :flat, options :flat :named) -.end - - -=item !set_resolves_list(class) - -Gets all the methods that the class has and adds them to the resolves list. - -=cut - -.sub '!set_resolves_list' - .param pmc class - .local pmc meths, it, res_list - meths = class.'methods'() - it = iter meths - res_list = root_new ['parrot';'ResizableStringArray'] - it_loop: - unless it goto it_loop_end - $S0 = shift it - $P0 = meths[$S0] - $I0 = isa $P0, 'MultiSub' - if $I0 goto it_loop - push res_list, $S0 - goto it_loop - it_loop_end: - class.'resolve_method'(res_list) -.end - - -=item !compose_role_attributes(class, role) - -Helper method to compose the attributes of a role into a class. - -=cut - -.sub '!compose_role_attributes' - .param pmc class - .param pmc role - - # Need to get hold of attribute order list for the class. - .local pmc attr_order_list - attr_order_list = getprop '@!attribute_list', class - unless null attr_order_list goto have_attr_order_list - attr_order_list = root_new ['parrot';'ResizableStringArray'] - setprop class, '@!attribute_list', attr_order_list - have_attr_order_list: - - .local pmc role_attrs, class_attrs, ra_iter, fixup_list - .local string cur_attr - role_attrs = inspect role, "attributes" - class_attrs = class."attributes"() - fixup_list = root_new ['parrot';'ResizableStringArray'] - ra_iter = iter role_attrs - ra_iter_loop: - unless ra_iter goto ra_iter_loop_end - cur_attr = shift ra_iter - - # Check that this attribute doesn't conflict with one already in the class. - $I0 = exists class_attrs[cur_attr] - unless $I0 goto no_conflict - - # We have a name conflict. Let's compare the types. If they match, then we - # can merge the attributes. - .local pmc class_attr_type, role_attr_type - $P0 = class_attrs[cur_attr] - if null $P0 goto conflict - class_attr_type = $P0['type'] - if null class_attr_type goto conflict - $P0 = role_attrs[cur_attr] - if null $P0 goto conflict - role_attr_type = $P0['type'] - if null role_attr_type goto conflict - $I0 = '!SAMETYPE_EXACT'(class_attr_type, role_attr_type) - if $I0 goto merge - - conflict: - $S0 = "Conflict of attribute '" - $S0 = concat cur_attr - $S0 = concat "' in composition of role '" - $S1 = role - $S0 = concat $S1 - $S0 = concat "'" - 'die'($S0) - - no_conflict: - addattribute class, cur_attr - push fixup_list, cur_attr - push attr_order_list, cur_attr - merge: - goto ra_iter_loop - ra_iter_loop_end: - - # Now we need, for any merged in attributes, to copy property data. - .local pmc fixup_iter, class_props, role_props, props_iter - class_attrs = class."attributes"() - fixup_iter = iter fixup_list - fixup_iter_loop: - unless fixup_iter goto fixup_iter_loop_end - cur_attr = shift fixup_iter - role_props = role_attrs[cur_attr] - class_props = class_attrs[cur_attr] - props_iter = iter role_props - props_iter_loop: - unless props_iter goto props_iter_loop_end - $S0 = shift props_iter - $P0 = role_props[$S0] - class_props[$S0] = $P0 - goto props_iter_loop - props_iter_loop_end: - goto fixup_iter_loop - fixup_iter_loop_end: -.end - - -=item !add_metaclass_method - -=cut - -.sub '!add_metaclass_method' - .param pmc metaclass - .param pmc name - .param pmc method - - # Create role for the method and mix it into the meta-class. - $P0 = root_new ['parrot';'P6role'] - $S0 = name - addmethod $P0, $S0, method - 'infix:does'(metaclass, $P0) - - # Add forward method to the class itself. - .lex '$meth_name', name - .const 'Sub' $P1 = '!metaclass_method_forwarder' - $P1 = newclosure $P1 - $P0 = getattribute metaclass, 'parrotclass' - $P0.'add_method'(name, $P1) -.end -.sub '!metaclass_method_forwarder' :outer('!add_metaclass_method') :method :anon - .param pmc pos_args :slurpy - .param pmc named_args :slurpy :named - $P0 = self.'HOW'() - $P1 = find_lex '$meth_name' - $S0 = $P1 - .tailcall $P0.$S0(self, pos_args :flat, named_args :flat :named) -.end - - -=item !create_parametric_role - -Helper method for creating parametric roles. - -=cut - -.sub '!create_parametric_role' - .param pmc metarole - '!meta_compose'(metarole) - .local pmc parrotrole, orig_role, meths, meth_iter - parrotrole = getattribute metarole, 'parrotclass' - orig_role = getprop '$!orig_role', parrotrole - meths = orig_role.'methods'() - meth_iter = iter meths - it_loop: - unless meth_iter goto it_loop_end - $S0 = shift meth_iter - $P0 = meths[$S0] - $P1 = clone $P0 - $P2 = getprop '$!signature', $P0 - setprop $P1, '$!signature', $P2 - $I0 = isa $P0, 'Code' - unless $I0 goto ret_pir_skip_rs - $P2 = getattribute $P0, ['Sub'], 'proxy' - $P2 = getprop '$!real_self', $P2 - $P3 = getattribute $P1, ['Sub'], 'proxy' - setprop $P3, '$!real_self', $P2 - ret_pir_skip_rs: - addmethod parrotrole, $S0, $P1 - goto it_loop - it_loop_end: - .return (parrotrole) -.end - - -=item !create_simple_role(name) - -Internal helper method to create a role with a single parameterless variant. - -=cut - -.sub '!create_simple_role' - .param string name - .local pmc info, role, helper - - # Create Parrot-level role. Need to make sure it gets its methods from - # the right namespace. - .local pmc ns - ns = split '::', name - name = ns[-1] - info = root_new ['parrot';'Hash'] - info['name'] = name - info['namespace'] = ns - role = root_new ['parrot';'P6role'], info - - # Now we need to wrap it up as a Perl6Role. - helper = find_name '!create_simple_role_helper' - helper = clone helper - setprop helper, '$!metarole', role - $P0 = allocate_signature 0 - setprop helper, '$!signature', $P0 - role = new ['Perl6Role'] - transform_to_p6opaque role - - $P0 = box name - setattribute role, '$!shortname', $P0 - role.'!add_variant'(helper) - - # Store it in the namespace. - ns = clone ns - $S0 = pop ns - set_hll_global ns, $S0, role - .return(role) -.end -.sub '!create_simple_role_helper' - $P0 = getinterp - $P0 = $P0['sub'] - $P0 = getprop '$!metarole', $P0 - .return ($P0) -.end - - -=item !create_anon_enum(value_list) - -Constructs a Mapping, based upon the values list. - -=cut - -.sub '!create_anon_enum' - .param pmc values - - # Put the values into list context, so case of a single valued enum works. - values = values.'list'() - - # For now, we assume integer type, unless we have a first pair that says - # otherwise. - .local pmc cur_val - cur_val = box 0 - - # Iterate over values and make mapping. - .local pmc result, values_it, cur_item - result = new ['Mapping'] - values_it = iter values - values_loop: - unless values_it goto values_loop_end - cur_item = shift values_it - $I0 = isa cur_item, 'Perl6Pair' - if $I0 goto pair - - nonpair: - $P0 = 'postfix:++'(cur_val) - result[cur_item] = $P0 - goto values_loop - - pair: - cur_val = cur_item.'value'() - $P0 = cur_item.'key'() - result[$P0] = cur_val - cur_val = clone cur_val - 'postfix:++'(cur_val) - goto values_loop - - values_loop_end: - .return (result) -.end - - -=item !create_enum(name, type, value_list) - -Constructs an enumeration. - -=cut - -.sub '!create_enum' - .param string name - .param pmc values - - # Use !create_anon_enum to associate all names with their underlying - # values. - values = '!create_anon_enum'(values) - - # Create a role for the enumeration and mark it as an enum. - .local pmc para_role, role - para_role = '!create_simple_role'(name) - role = para_role.'!select'() - $P0 = box 1 - setprop role, '$!is_enum', $P0 - - # Compute short name and add attribute to the role; type is this - # role so that you can only store other enum elements in the slut. - .local pmc ns, outer_ns - .local string short_name, attr_name - $P0 = get_hll_global [ 'Perl6';'Compiler' ], 'parse_name' - $P1 = null - ns = $P0($P1, name) - outer_ns = clone ns - short_name = pop outer_ns - attr_name = concat "$!", short_name - '!meta_attribute'(role, attr_name, 'Perl6Scalar', 'type'=>role) - - # Add an l-value accessor method for the attribute. - .local pmc attr_name_pmc, accessor - attr_name_pmc = box attr_name - .lex '$attr_name', attr_name_pmc - .const 'Sub' accessor = '!create_enum_helper_accessor' - accessor = newclosure accessor - addmethod role, short_name, accessor - - # Next, we need methods on the role for each variant, returning - # a true or false value depending on if the current value of the - # enum is set to that. - .const 'Sub' checker_create = '!create_enum_helper_checker_create' - .local pmc it, cur_value - it = iter values - checker_loop: - unless it goto checker_loop_end - $S0 = shift it - cur_value = values[$S0] - $P0 = checker_create(attr_name, cur_value) - addmethod role, $S0, $P0 - goto checker_loop - checker_loop_end: - - # We'll make a list of the values and the .pick method on the role will - # use that (Enum.pick then just works through punning). - .local pmc value_list - .local string value_name - value_list = root_new ['parrot';'ResizablePMCArray'] - .lex '@values', value_list - .const 'Sub' pick = '!create_enum_helper_pick' - pick = newclosure pick - addmethod role, 'pick', pick - - # Go over all of the values... - it = iter values - value_loop: - unless it goto value_loop_end - value_name = shift it - cur_value = values[value_name] - - # Mix the enum role into it, so Val ~~ Enum will work, and set the value - # field to itself plus set it readonly. - cur_value = 'infix:but'(cur_value, role) - $P0 = cur_value.short_name() - copy $P0, cur_value - $P1 = box 1 - setprop $P0, 'readonly', $P1 - - # It should also do Abstraction. - $P0 = get_hll_global 'Abstraction' - 'infix:does'(cur_value, $P0) - - # Now create and mix in another role to provide .WHAT, .perl and .name. - $S0 = concat name, '::' - $S0 = concat value_name - $P0 = '!create_enum_value_role'(role, $S0, value_name) - 'infix:does'(cur_value, $P0) - - # Put it onto the list for .pick and install it in the namespace(s). - push value_list, cur_value - set_hll_global ns, value_name, cur_value - set_hll_global outer_ns, value_name, cur_value - - goto value_loop - value_loop_end: -.end -.sub '!create_enum_helper_accessor' :method :outer('!create_enum') - $P0 = find_lex '$attr_name' - $S0 = $P0 - $P0 = getattribute self, $S0 - .return ($P0) -.end -.sub '!create_enum_helper_checker_create' - .param pmc attr_name - .param pmc value - .lex '$attr_name', attr_name - .lex '$value', value - .const 'Sub' $P0 = '!create_enum_helper_checker' - $P0 = newclosure $P0 - .return ($P0) -.end -.sub '!create_enum_helper_checker' :method :outer('!create_enum_helper_checker_create') - $P0 = find_lex '$attr_name' - $S0 = $P0 - $P0 = getattribute self, $S0 - $P1 = find_lex '$value' - .tailcall 'infix:eq'($P0, $P1) -.end -.sub '!create_enum_helper_pick' :method :outer('!create_enum') - .param pmc pos_args :slurpy - $P0 = find_lex '@values' - $P0 = 'list'($P0 :flat) - .tailcall $P0.'pick'(pos_args :flat) -.end -.sub '!create_enum_value_role' - .param pmc enum_role - .param pmc long_name - .param pmc short_name - .lex '$enum_role', enum_role - .lex '$long_name', long_name - .lex '$short_name', short_name - $P0 = root_new ['parrot';'P6role'] - .const 'Sub' ACCEPTS = '!create_enum_value_role_ACCEPTS' - ACCEPTS = newclosure ACCEPTS - addmethod $P0, 'ACCEPTS', ACCEPTS - .const 'Sub' WHAT = '!create_enum_value_role_WHAT' - WHAT = newclosure WHAT - addmethod $P0, 'WHAT', WHAT - .const 'Sub' name = '!create_enum_value_role_name' - name = newclosure name - addmethod $P0, 'name', name - .const 'Sub' perl = '!create_enum_value_role_perl' - perl = newclosure perl - addmethod $P0, 'perl', perl - .return ($P0) -.end -.sub '!create_enum_value_role_ACCEPTS' :method :outer('!create_enum_value_role') - .param pmc topic - $P0 = find_lex '$enum_role' - $I0 = does topic, $P0 - unless $I0 goto done - $P0 = find_lex '$short_name' - $S0 = $P0 - $I0 = topic.$S0() - done: - .return ($I0) -.end -.sub '!create_enum_value_role_WHAT' :method :outer('!create_enum_value_role') - $P0 = find_lex '$enum_role' - .return ($P0) -.end -.sub '!create_enum_value_role_name' :method :outer('!create_enum_value_role') - $P0 = find_lex '$short_name' - .return ($P0) -.end -.sub '!create_enum_value_role_perl' :method :outer('!create_enum_value_role') - $P0 = find_lex '$long_name' - .return ($P0) -.end - - -=item !fixup_routine_type(sub, new_type) - -Reblesses a sub into a new type. - -=cut - -.sub '!fixup_routine_type' - .param pmc sub - .param string new_type_name - - # Create the correct object and rebless the sub into that class. - .local pmc new_type, p6meta - p6meta = get_hll_global ['Perl6Object'], '$!P6META' - new_type = get_hll_global new_type_name - $P0 = p6meta.'get_parrotclass'(new_type) - rebless_subclass sub, $P0 - transform_to_p6opaque sub - - # We also make sure the Parrot-level sub has a backlink to the - # Rakudo-level object, since interpinfo only gives us the - # Parrot-level sub. - $P0 = getattribute sub, ['Sub'], 'proxy' - setprop $P0, '$!real_self', sub -.end - - -=item !state_var_init - -Loads any existing values of state variables for a block. - -=cut - -.sub '!state_var_init' - .local pmc lexpad, state_store, names_it - $P0 = getinterp - lexpad = $P0['lexpad'; 1] - $P0 = $P0['sub'; 1] - state_store = getprop '$!state_store', $P0 - unless null state_store goto have_state_store - state_store = root_new ['parrot';'Hash'] - setprop $P0, '$!state_store', state_store - have_state_store: - - names_it = iter state_store - names_loop: - unless names_it goto names_loop_end - $S0 = shift names_it - $P0 = state_store[$S0] - lexpad[$S0] = $P0 - goto names_loop - names_loop_end: -.end - - -=item !state_var_inited - -Takes the name of a state variable and returns true if it's been -initialized already. - -=cut - -.sub '!state_var_inited' - .param string name - $P0 = getinterp - $P0 = $P0['sub'; 1] - $P0 = getprop '$!state_store', $P0 - $P0 = $P0[name] - $I0 = isnull $P0 - $I0 = not $I0 - .return ($I0) -.end - - -=item !MAKE_WHATEVER_CLOSURE - -Creates whatever closures (*.foo => { $_.foo }) - -=cut - -.sub '!MAKE_WHATEVER_CLOSURE' - .param pmc whatever - .param pmc pos_args :slurpy - .param pmc named_args :slurpy :named - .local pmc name - $P0 = getinterp - $P0 = $P0['sub'] - name = getprop 'name', $P0 - .lex '$name', name - .lex '$pos_args', pos_args - .lex '$named_args', named_args - .const 'Sub' $P0 = '!whatever_dispatch_helper' - $P0 = newclosure $P0 - .const 'Sub' fixup = '!fixup_routine_type' - fixup($P0, "Block") - .return ($P0) -.end -.sub '!whatever_dispatch_helper' :outer('!MAKE_WHATEVER_CLOSURE') - .param pmc obj - $P0 = find_lex '$name' - $S0 = $P0 - $P1 = find_lex '$pos_args' - $P2 = find_lex '$named_args' - .tailcall obj.$S0($P1 :flat, $P2 :flat :named) -.end - - -=item !HANDLES_HELPER - -=cut - -.sub '!HANDLES_DISPATCH_HELPER' - .param pmc obj - .param pmc pos_args :slurpy - .param pmc name_args :slurpy :named - - # Look up attribute and method name, and look up the attribute. - .local pmc attr - .local string attrname, methodname - $P0 = getinterp - $P0 = $P0['sub'] - $P1 = getprop 'methodname', $P0 - methodname = $P1 - $P1 = getprop 'attrname', $P0 - attrname = $P1 - attr = getattribute obj, attrname - - # If it's an array, need to iterate over the set of options. Otherwise, - # just delegate. - $S0 = substr attrname, 0, 1 - if $S0 == '@' goto handles_on_array - .tailcall attr.methodname(pos_args :flat, name_args :flat :named) - handles_on_array: - .local pmc handles_array_it - handles_array_it = iter attr - handles_array_it_loop: - unless handles_array_it goto handles_array_it_loop_end - $P0 = shift handles_array_it - $I0 = $P0.'can'(methodname) - unless $I0 goto handles_array_it_loop - .tailcall $P0.methodname(pos_args :flat, name_args :flat :named) - handles_array_it_loop_end: - 'die'("You used handles on attribute ", attrname, ", but nothing in the array can do method ", methodname) -.end - - -=item !make_type_fail_message - -Makes a type check failure error message, so we don't have to be doing so all -over the rest of the code base. - -=cut - -.sub '!make_type_fail_message' - .param string what_failed - .param pmc got_type - .param pmc wanted_type - - # Initial bit. - .local string output - output = concat what_failed, " type check failed; expected " - - # Work out what we were looking for and show that. - $I0 = isa wanted_type, 'P6protoobject' - if $I0 goto simple_type - $I0 = isa wanted_type, 'Junction' - if $I0 goto junc_wanted - simple_type: - $P0 = wanted_type.'WHAT'() - goto wanted_type_done - junc_wanted: - $P0 = wanted_type.'eigenstates'() - $I0 = elements $P0 - if $I0 > 1 goto wanted_type_done - $P0 = $P0[0] - wanted_type_done: - $S0 = $P0.'perl'() - output = concat $S0 - - # Report what we actually got. - output = concat ", but got " - $P0 = got_type.'WHAT'() - $S0 = $P0.'perl'() - output = concat $S0 - - .return (output) -.end - - -=item !bindability_checker - -Invokes a sub in bindability checking mode. Catches any exceptions that are -thrown while trying to bind. If the bind fails, returns null. Otherwise, we -return the resume continuation so we can continue execution after the bind. - -=cut - -.sub '!bindability_checker' - .param pmc orig_sub - .param pmc pos_args - .param pmc named_args - - # Clone sub and attach a prop to say we're just doing a bindability check. - .local pmc sub - sub = clone orig_sub - .fixup_cloned_sub(orig_sub, sub) - setprop sub, '$!bind_check_only', sub - - # Set up exception handler and invoke. We really should get an exception - # whether it binds or not; if we don't, best we can do is hand back the - # sub, but warn something may be very wrong. - push_eh oh_noes - sub(pos_args :flat, named_args :flat :named) - pop_eh - warn("Potential internal error: bindability check may have done more than just binding.") - .return (sub) - - oh_noes: - .local pmc ex - .get_results (ex) - if ex == '__BIND_SUCCESSFUL__' goto success - null $P0 - .return ($P0) - success: - $P0 = ex["resume"] - .return ($P0) -.end - - -=item !deferal_fail - -Used by P6invocation to help us get soft-failure semantics when no deferal -is possible. - -=cut - -.sub '!deferal_fail' - .param pmc pos_args :slurpy - .param pmc named_args :slurpy :named - .lex '__CANDIDATE_LIST__', $P0 - .tailcall '!FAIL'('No method to defer to') -.end - -=back - -=cut - -# Local Variables: -# mode: pir -# fill-column: 100 -# End: -# vim: expandtab shiftwidth=4 ft=pir: diff --git a/src/old/builtins-old/io.pir b/src/old/builtins-old/io.pir deleted file mode 100644 index 69cdf88b94e..00000000000 --- a/src/old/builtins-old/io.pir +++ /dev/null @@ -1,227 +0,0 @@ -## $Id$ - -=head1 NAME - -src/builtins/io.pir - Perl6 builtins for I/O - -=head1 Functions - -=over 4 - -=cut - -.namespace [] - -=item printf - -Parses a format string and prints formatted output according to it. - -=cut - -.sub 'printf' - .param pmc args :slurpy - .local pmc it, out - out = '!find_contextual'('$*OUT') - $S0 = 'sprintf'(args :flat) - out.'print'($S0) - .return (1) -.end - - -.sub 'open' - .param string filename - .param int r :named('r') :optional - .param int w :named('w') :optional - .param int a :named('a') :optional - - # Work out a mode string. XXX Default to r? - .local string mode - if r goto is_read - if w goto is_write - if a goto is_append -is_read: - mode = "r" - goto done_mode -is_write: - mode = "w" - goto done_mode -is_append: - mode = "wa" - goto done_mode -done_mode: - - # Open file to get PIO file handle. - $P0 = open filename, mode - if $P0 goto opened_ok - 'die'("Unable to open file") # XXX better message - - opened_ok: - # Set default encoding to utf8 - $P0.'encoding'('utf8') - # Create IO object and set handle. - .local pmc obj - obj = get_hll_global 'IO' - obj = obj.'new'() - setattribute obj, "$!PIO", $P0 - .return(obj) -.end - -.sub 'close' - .param pmc obj - obj.'close'() -.end - -.sub 'slurp' - .param string filename - .local string contents - - $P0 = 'open'(filename, 'r') - contents = $P0.'slurp'() - 'close'($P0) - .return(contents) -.end - - -=item unlink LIST - -Deletes a list of files. Returns the number of files successfully -deleted. - - $cnt = unlink 'a', 'b', 'c'; - -Be warned that unlinking a directory can inflict damage on your filesystem. -Finally, using C on directories is not supported on many operating -systems. Use C instead. - -It is an error to use bare C without arguments. - -=cut - -.sub 'unlink' - .param pmc to_delete :slurpy - .local pmc it, os - .local int success_count - - # Error with no arguments. - $I0 = elements to_delete - if $I0 goto ok - 'die'("Cannot call unlink without any arguments") - ok: - - os = root_new ['parrot';'OS'] - success_count = 0 - it = iter to_delete - it_loop: - unless it goto it_loop_end - $S0 = shift it - push_eh unlink_skip - os.'rm'($S0) - inc success_count - unlink_skip: - pop_eh - goto it_loop - it_loop_end: - - .return (success_count) -.end - - -.sub '!qx' - .param string cmd - .local pmc pio - '!hash_to_env'() - pio = open cmd, 'rp' - unless pio goto err_qx - pio.'encoding'('utf8') - $P0 = pio.'readall'() - pio.'close'() - .return ($P0) - err_qx: - .tailcall '!FAIL'('Unable to execute "', cmd, '"') -.end - - -=item chdir STRING - -Changes the current working directory. - - chdir '/new/dir'; - -On success the value of the new directory is put in $*CWD and a -true value is returned. - -=cut - -.sub 'chdir' - .param string newdir - - # Try to change directory; if we fail, exception thrown, so catch - # it and fail if needed. - .local pmc os - os = root_new ['parrot';'OS'] - push_eh failure - os.'chdir'(newdir) - pop_eh - - # Update $*CWD and we're done. - $S0 = os."cwd"() - $P0 = box $S0 - set_hll_global '$CWD', $P0 - $P0 = get_hll_global ['Bool'], 'True' - .return ($P0) - - failure: - pop_eh - .tailcall '!FAIL'('Unable to change to directory "', newdir, '"') -.end - - -=item mkdir STRING [, MODE] - -Creates a new directory, optionally setting specific permissions (which -are modified by the user's umask). If omitted, the permissions default -to 0o777 (full access to all). - - mkdir '/new/dir'; - mkdir '/new/dir', 0o755; - -On success a true value is returned. - -=cut - -.sub 'mkdir' - .param string newdir - .param int mode :optional - .param int has_mode :opt_flag - - # Default mode to 0o777 - if has_mode goto have_mode - mode = 0o777 - have_mode: - - # Try to create the directory; if we fail, exception thrown, so catch - # it and fail if needed. - .local pmc os - os = root_new ['parrot';'OS'] - push_eh failure - os.'mkdir'(newdir, mode) - pop_eh - - # Success, we're done. - $P0 = get_hll_global ['Bool'], 'True' - .return ($P0) - - failure: - pop_eh - .tailcall '!FAIL'('Unable to create directory "', newdir, '"') -.end - -=back - -=cut - -# Local Variables: -# mode: pir -# fill-column: 100 -# End: -# vim: expandtab shiftwidth=4 ft=pir: diff --git a/src/old/builtins-old/match.pir b/src/old/builtins-old/match.pir deleted file mode 100644 index 651dce9e652..00000000000 --- a/src/old/builtins-old/match.pir +++ /dev/null @@ -1,58 +0,0 @@ -## $Id$ - -=head1 NAME - -src/builtins/match.pir - Perl6 builtins for smart matching - -=head1 Functions - -=over 4 - -=cut - -.namespace [] - -.sub 'infix:~~' :multi() - .param pmc topic - .param pmc x - .tailcall x.'ACCEPTS'(topic) -.end - - -.sub 'infix:!~~' - .param pmc topic - .param pmc x - .tailcall x.'REJECTS'(topic) -.end - -=item make($item) - -Equivalent to C<$/."!make"($item)>. This sets the ast value of -the current match object. - -=cut - -.sub 'make' - .param pmc value - $P0 = getinterp - $P1 = $P0['lexpad';1] - $P2 = $P1['$/'] - $I0 = can $P2, '!make' - unless $I0 goto err_make - $P2.'!make'(value) - .return () - err_make: - 'die'("make() cannot set result of non-Match object in $/") - .return () -.end - - -=back - -=cut - -# Local Variables: -# mode: pir -# fill-column: 100 -# End: -# vim: expandtab shiftwidth=4 ft=pir: diff --git a/src/old/builtins-old/math.pir b/src/old/builtins-old/math.pir deleted file mode 100644 index 44bda67db7e..00000000000 --- a/src/old/builtins-old/math.pir +++ /dev/null @@ -1,165 +0,0 @@ -## $Id$ - -=head1 NAME - -src/builtins/math.pir - Perl6 math functions - -=head1 Math::Basic - -=head2 Functions - -=over 4 - -=item e - - constant Num Num::e = exp(1); - -=cut - -.sub 'e' - $N0 = exp 1 - .return ($N0) -.end - -=item Inf / NaN - -=cut - -.sub 'Inf' - $N0 = 'Inf' - .return ($N0) -.end - -.sub 'NaN' - $N0 = 'NaN' - .return ($N0) -.end - - -=item pi - - constant Num Num::pi = atan(1,1) * 4; - constant Int Int::pi = 3; - -=cut - -.sub 'pi' - .param pmc x :slurpy - ## 0-argument test, RT#56366 - unless x goto no_args - die "too many arguments passed - 0 params expected" - no_args: - $N0 = atan 1 - $N0 *= 4 - .return ($N0) -.end - - -=item radcalc - -=cut - -.sub 'radcalc' - .param int radix - .param string intpart - .param string fracpart :optional - .param int has_fracpart :opt_flag - .param num base :optional - .param int has_base :opt_flag - .param num exp :optional - .param int has_exp :opt_flag - .local num result, fracdivisor, magnitude - .local pmc it - - if radix <= 1 goto err_range - if radix > 36 goto err_range - - result = 0.0 - fracdivisor = 1.0 - - $P0 = split '', intpart - it = iter $P0 - - lp1: # Accumulate over decimal part - unless it goto ex1 - $S0 = shift it - $S0 = downcase $S0 - if $S0 == "_" goto lp1 - $I0 = index "0123456789abcdefghijklmnopqrstuvwxyz", $S0 - if $I0 == -1 goto err_char - $N0 = $I0 - result *= radix - result += $N0 - goto lp1 - - ex1: - unless has_fracpart goto nofracpart - $I0 = length fracpart - unless $I0 goto nofracpart - $P0 = split '', fracpart - $P99 = shift $P0 # remove the radix point - - lp2: # Accumulate over fractional part, keep length - unless it goto ex2 - $S0 = shift it - $S0 = downcase $S0 - if $S0 == "_" goto lp2 - $I0 = index "0123456789abcdefghijklmnopqrstuvwxyz", $S0 - if $I0 == -1 goto err_char - $N0 = $I0 - - result *= radix - result += $N0 - fracdivisor *= radix - goto lp2 - - ex2: - result /= fracdivisor - - nofracpart: - unless has_base goto ret - magnitude = base ** exp - result *= magnitude - ret: - .return (result) - - err_range: - die "radix out of range (2-36)" - err_char: - $S0 = concat "unrecognized character: ", $S0 - die $S0 -.end - - -=back - -=head2 TODO: Functions - -=over 4 - -=item rand - - our Num multi Math::Basic::rand ( Num $x = 1 ) - -Pseudo random number in range C<< 0 ..^ $x >>. That is, C<0> is theoretically possible, -while C<$x> is not. - -=item srand - - multi Math::Basic::srand ( Num $seed = default_seed_algorithm()) - -Seed the generator C uses. C<$seed> defaults to some combination -of various platform dependent characteristics to yield a non-deterministic seed. -Note that you get one C for free when you start a Perl program, so -you I call C yourself if you wish to specify a deterministic seed -(or if you wish to be differently nondeterministic). - -=back - -=cut - -# Local Variables: -# mode: pir -# fill-column: 100 -# End: -# vim: expandtab shiftwidth=4 ft=pir: diff --git a/src/old/builtins-old/named-unary.pir b/src/old/builtins-old/named-unary.pir deleted file mode 100644 index 6d67a706b63..00000000000 --- a/src/old/builtins-old/named-unary.pir +++ /dev/null @@ -1,69 +0,0 @@ -## $Id$ - -=head1 NAME - -src/builtins/named-unary.pir - Perl6 named unary builtins - -=head1 Functions - -=over 4 - -=cut - -.namespace [] - -=item HOW($x) - -=item WHAT($x) - -Return the metaclass or protoobject for C<$x>. - -=cut - -.sub 'HOW' - .param pmc x - .tailcall x.'HOW'() -.end - - -.sub 'WHAT' - .param pmc x - .tailcall x.'WHAT'() -.end - - -=item defined($x) - -Returns a true value if $x is defined, and a false value otherwise. - -=cut - -.sub 'defined' - .param pmc x - $I0 = defined x - .return ($I0) -.end - - -=item undefine $x - -Sets $x to an undefined value - -=cut - -.sub 'undefine' - .param pmc x - $P0 = root_new ['parrot';'Perl6Scalar'] - copy x, $P0 -.end - - -=back - -=cut - -# Local Variables: -# mode: pir -# fill-column: 100 -# End: -# vim: expandtab shiftwidth=4 ft=pir: diff --git a/src/old/builtins-old/op.pir b/src/old/builtins-old/op.pir deleted file mode 100644 index 12a39ddb9b8..00000000000 --- a/src/old/builtins-old/op.pir +++ /dev/null @@ -1,545 +0,0 @@ -## $Id$ - -=head1 NAME - -src/builtins/op.pir - Perl 6 builtin operators - -=head1 Functions - -=over 4 - -=cut - -.namespace [] - -## This is used by integer computations, to upgrade the answer and return a -## Num if we overflow. We may want to return something like a BigInt in the -## future, but we don't have that yet and this gives something closer to the -## correct semantics than not upgrading an Int at all. -.sub '!upgrade_to_num_if_needed' - .param num test - if test > 2147483647.0 goto upgrade - if test < -2147483648.0 goto upgrade - $I0 = test - .return ($I0) - upgrade: - .return (test) -.end - - -## autoincrement -.sub 'prefix:++' :multi(_) :subid('!prefix:++') - .param pmc a - $I0 = defined a - unless $I0 goto inc_undef - $P1 = a.'succ'() - .tailcall 'infix:='(a, $P1) - inc_undef: - .tailcall 'infix:='(a, 1) -.end - -.sub 'postfix:++' :multi(_) :subid('!postfix:++') - .param pmc a - $P0 = a.'clone'() - .const 'Sub' $P1 = '!prefix:++' - $P1(a) - .return ($P0) -.end - -.sub 'prefix:--' :multi(_) :subid('!prefix:--') - .param pmc a - $I0 = defined a - unless $I0 goto dec_undef - $P1 = a.'pred'() - .tailcall 'infix:='(a, $P1) - dec_undef: - .tailcall 'infix:='(a, -1) -.end - -.sub 'postfix:--' :multi(_) - .param pmc a - $P0 = a.'clone'() - .const 'Sub' $P1 = '!prefix:--' - $P1(a) - .return ($P0) -.end - -.sub 'prefix:++' :multi(Integer) :subid('!prefix:++Int') - .param pmc a - unless a < 2147483647 goto fallback - $P0 = getprop 'readonly', a - unless null $P0 goto fallback - $P0 = getprop 'type', a - if null $P0 goto fast_inc - $P1 = get_hll_global 'Int' - $I0 = issame $P0, $P1 - unless $I0 goto fallback - fast_inc: - inc a - .return (a) - fallback: - .const 'Sub' fb = '!prefix:++' - .tailcall fb(a) -.end - -.sub 'postfix:++' :multi(Integer) - .param pmc a - $P0 = deobjectref a - $P0 = clone $P0 - .const 'Sub' $P1 = '!prefix:++Int' - $P1(a) - .return ($P0) -.end - - -## symbolic unary -.sub 'prefix:!' :multi(_) - .param pmc a - if a goto a_true - $P0 = get_hll_global ['Bool'], 'True' - .return ($P0) - a_true: - $P0 = get_hll_global ['Bool'], 'False' - .return ($P0) -.end - - -.sub 'prefix:^?' :multi(_) - .param pmc a - .tailcall 'prefix:!'(a) -.end - - -.sub 'prefix:+' :multi(_) - .param num a - .return (a) -.end - - -.sub 'prefix:+' :multi('Integer') - .param num a - .tailcall '!upgrade_to_num_if_needed'(a) -.end - - -.sub 'prefix:?' :multi(_) - .param pmc a - if a goto a_true - $P0 = get_hll_global ['Bool'], 'False' - .return ($P0) - a_true: - $P0 = get_hll_global ['Bool'], 'True' - .return ($P0) -.end - - -## TODO: prefix:= prefix:* prefix:** prefix:~^ prefix:+^ - - -.sub 'infix:xx' :multi(_,_) - .param pmc a - .param int n - $P0 = 'list'() - loop: - unless n > 0 goto done - push $P0, a - dec n - goto loop - done: - .return ($P0) -.end - - -.sub 'infix:+&' :multi(_,_) - .param int a - .param int b - $I0 = band a, b - .return ($I0) -.end - - -.sub 'infix:+<' :multi(_,_) - .param int a - .param int b - $I0 = shl a, b - .return ($I0) -.end - - -.sub 'infix:+>' :multi(_,_) - .param int a - .param int b - $I0 = shr a, b - .return ($I0) -.end - - -.sub 'infix:~&' :multi(_,_) - .param string a - .param string b - $S0 = bands a, b - .return ($S0) -.end - - -## TODO: infix:~< infix:~> - - -## additive - -.sub 'infix:~' :multi(_,_) - .param string a - .param string b - $S0 = concat a, b - $P0 = new ['Str'] - assign $P0, $S0 - .return ($P0) -.end - - -.sub 'infix:+|' - .param int a - .param int b - $I0 = bor a, b - .return ($I0) -.end - - -.sub 'infix:+^' - .param int a - .param int b - $I0 = bxor a, b - .return ($I0) -.end - - -.sub 'infix:~|' - .param string a - .param string b - $S0 = bors a, b - .return ($S0) -.end - - -.sub 'infix:~^' - .param string a - .param string b - $S0 = bxors a, b - .return ($S0) -.end - - -.sub 'infix:?&' - .param int a - .param int b - $I0 = band a, b - $I0 = isne $I0, 0 - .return ($I0) -.end - - -.sub 'infix:?|' - .param int a - .param int b - $I0 = bor a, b - $I0 = isne $I0, 0 - .return ($I0) -.end - - -.sub 'infix:?^' - .param int a - .param int b - $I0 = bxor a, b - $I0 = isne $I0, 0 - .return ($I0) -.end - - -.sub 'true' :multi(_) - .param pmc a - .tailcall 'prefix:?'(a) -.end - - -.sub 'not' :multi(_) - .param pmc a - .tailcall 'prefix:!'(a) -.end - - -.sub 'infix:does' - .param pmc var - .param pmc role - .param pmc init_value :optional - .param int have_init_value :opt_flag - - # Get the class of the variable we're adding roles to. - .local pmc p6meta, parrot_class - var.'!rebox'() - parrot_class = class var - - # Derive a new class that does the role(s) specified. - .local pmc derived - derived = root_new ['parrot';'Class'] - addparent derived, parrot_class - $I0 = isa role, ['Perl6Role'] - if $I0 goto one_role_select - #$P0 = get_root_namespace ['parrot';'Role'] - #$P0 = get_class $P0 - $I0 = isa role, 'P6role' - if $I0 goto one_role - $I0 = isa role, ['List'] - if $I0 goto many_roles - error: - 'die'("'does' expects a role or a list of roles") - - one_role_select: - role = role.'!select'() - one_role: - addrole derived, role - '!compose_role_attributes'(derived, role) - goto added_roles - - many_roles: - .local pmc role_it, cur_role - role_it = iter role - roles_loop: - unless role_it goto roles_loop_end - cur_role = shift role_it - $I0 = isa cur_role, 'Role' - if $I0 goto have_parrot_role - $I0 = isa cur_role, 'Perl6Role' - unless $I0 goto error - cur_role = cur_role.'!select'() - have_parrot_role: - addrole derived, cur_role - '!compose_role_attributes'(derived, cur_role) - goto roles_loop - roles_loop_end: - added_roles: - - # Instantiate the class to make it form itself. - $P0 = new derived - - # Create a new meta-class, but associate with existing proto-object. - .local pmc p6meta, old_proto, new_proto - p6meta = get_hll_global ['Perl6Object'], '$!P6META' - new_proto = p6meta.'register'(derived) - $P0 = new_proto.'HOW'() - old_proto = var.'WHAT'() - setattribute $P0, 'protoobject', old_proto - - # Re-bless the object into the subclass. - rebless_subclass var, derived - - # We need to set any initial attribute values up. - .lex '$CLASS', new_proto - $P0 = find_method new_proto, 'BUILD' - $P0(var) - - # If we were given something to initialize with, do so. - unless have_init_value goto no_init - .local pmc attrs - .local string attr_name - attrs = inspect role, "attributes" - attrs = attrs.'keys'() - $I0 = elements attrs - if $I0 != 1 goto attr_error - attr_name = attrs[0] - attr_name = substr attr_name, 2 # lop off sigil and twigil - $P0 = var.attr_name() - 'infix:='($P0, init_value) - no_init: - - # We're done - return. - .return (var) - -attr_error: - 'die'("Can only supply an initialization value to a role with one attribute") -.end - - -.sub 'infix:but' - .param pmc var - .param pmc role - .param pmc value :optional - .param int have_value :opt_flag - - # First off, is the role actually a role? - $I0 = isa role, 'Perl6Role' - if $I0 goto have_role - $I0 = isa role, 'Role' - if $I0 goto have_role - - # If not, it may be an enum. If we don't have a value, get the class of - # the thing passed as a role and find out. - if have_value goto error - .local pmc maybe_enum - maybe_enum = role.'WHAT'() - $P0 = getprop '$!is_enum', maybe_enum - if null $P0 goto error - unless $P0 goto error - value = role - role = maybe_enum - goto have_role - unless null role goto have_role - - # Did anything go wrong? - error: - 'die'("The but operator can only be used with a role or enum value on the right hand side") - - # Now we have a role, copy the value and call does on the copy. - have_role: - $I0 = isa var, 'ObjectRef' - unless $I0 goto not_obj_ref - var = deref var - not_obj_ref: - var = clone var - if null value goto no_value - 'infix:does'(var, role, value) - goto return - no_value: - 'infix:does'(var, role) - return: - .return (var) -.end - - -=item !generate_meta_ops - -Generates meta-ops for user defined operators. - -=cut - -.sub '!generate_meta_ops' - .param string full_name - .param string equiv - - # If op is already generated, defined, we're done. - .local string name - name = substr full_name, 6 - $S0 = concat 'infix:R', name - $P0 = get_hll_global $S0 - unless null $P0 goto done - - # Generate all the names we'll need. - .local string assignment, reverse, cross, reduce, hyper1, hyper2, hyper3, hyper4 - .local string hyper1_asc, hyper2_asc, hyper3_asc, hyper4_asc - assignment = concat 'infix:', name - concat assignment, '=' - reverse = concat 'infix:R', name - cross = concat 'infix:X', name - reduce = concat 'prefix:[', name - concat reduce, ']' - hyper1_asc = concat 'infix:<<', name - concat hyper1_asc, '>>' - hyper2_asc = concat 'infix:>>', name - concat hyper2_asc, '<<' - hyper3_asc = concat 'infix:<<', name - concat hyper3_asc, '<<' - hyper4_asc = concat 'infix:>>', name - concat hyper4_asc, '>>' - hyper1 = concat unicode:"infix:\u00ab", name - concat hyper1, unicode:"\u00bb" - hyper2 = concat unicode:"infix:\u00bb", name - concat hyper2, unicode:"\u00ab" - hyper3 = concat unicode:"infix:\u00ab", name - concat hyper3, unicode:"\u00ab" - hyper4 = concat unicode:"infix:\u00bb", name - concat hyper4, unicode:"\u00bb" - - # Add all of the tokens. - .local pmc optable - optable = get_hll_global ['Perl6';'Grammar'], '$optable' - optable.'newtok'(assignment, 'equiv'=>'infix::=', 'lvalue'=>1) - optable.'newtok'(reduce, 'equiv'=>'infix:=') - optable.'newtok'(reverse, 'equiv'=>equiv) - optable.'newtok'(cross, 'equiv'=>'infix:X') - optable.'newtok'(hyper1, 'equiv'=>equiv) - optable.'newtok'(hyper1_asc, 'equiv'=>equiv, 'subname'=>hyper1) - optable.'newtok'(hyper2, 'equiv'=>equiv) - optable.'newtok'(hyper2_asc, 'equiv'=>equiv, 'subname'=>hyper2) - optable.'newtok'(hyper3, 'equiv'=>equiv) - optable.'newtok'(hyper3_asc, 'equiv'=>equiv, 'subname'=>hyper3) - optable.'newtok'(hyper4, 'equiv'=>equiv) - optable.'newtok'(hyper4_asc, 'equiv'=>equiv, 'subname'=>hyper4) - - # Now generate the subs. - $P0 = '!generate_meta_op_sub'('!generate_meta_op_helper_simple', '!ASSIGNMETAOP', name) - set_hll_global assignment, $P0 - $P0 = '!generate_meta_op_sub'('!generate_meta_op_helper_reduce', name) - set_hll_global reduce, $P0 - $P0 = '!generate_meta_op_sub'('!generate_meta_op_helper_reverse', full_name) - set_hll_global reverse, $P0 - $P0 = '!FAIL'() - $P0 = '!generate_meta_op_sub'('!generate_meta_op_helper_cross', name) - set_hll_global cross, $P0 - $P0 = '!generate_meta_op_sub'('!generate_meta_op_helper_hyper', '!HYPEROP', name, 0, 0) - set_hll_global hyper1, $P0 - $P0 = '!generate_meta_op_sub'('!generate_meta_op_helper_hyper', '!HYPEROP', name, 1, 1) - set_hll_global hyper2, $P0 - $P0 = '!generate_meta_op_sub'('!generate_meta_op_helper_hyper', '!HYPEROP', name, 0, 1) - set_hll_global hyper3, $P0 - $P0 = '!generate_meta_op_sub'('!generate_meta_op_helper_hyper', '!HYPEROP', name, 1, 0) - set_hll_global hyper4, $P0 - done: -.end -.sub '!generate_meta_op_sub' - .param string which_helper - .param pmc delegate_to - .param pmc args :slurpy - .lex '$delegate_to', delegate_to - .lex '@args', args - $P0 = find_name which_helper - $P0 = newclosure $P0 - .return ($P0) -.end -.sub '!generate_meta_op_helper_simple' :outer('!generate_meta_op_sub') - .param pmc a - .param pmc b - $P0 = find_lex '$delegate_to' - $S0 = $P0 - $P0 = find_name $S0 - $P1 = find_lex '@args' - .tailcall $P0($P1 :flat, a, b) -.end -.sub '!generate_meta_op_helper_reverse' :outer('!generate_meta_op_sub') - .param pmc a - .param pmc b - $P0 = find_lex '$delegate_to' - $S0 = $P0 - $P0 = find_name $S0 - .tailcall $P0(b, a) -.end -.sub '!generate_meta_op_helper_reduce' :outer('!generate_meta_op_sub') - .param pmc args :slurpy - $P0 = find_lex '$delegate_to' - .tailcall '!REDUCEMETAOP'($P0, 0, args :flat) -.end -.sub '!generate_meta_op_helper_cross' :outer('!generate_meta_op_sub') - .param pmc args :slurpy - $P0 = find_lex '$delegate_to' - .tailcall '!CROSSMETAOP'($P0, 0, 0, args :flat) -.end -.sub '!generate_meta_op_helper_hyper' :outer('!generate_meta_op_sub') - .param pmc a - .param pmc b - $P0 = find_lex '$delegate_to' - $S0 = $P0 - $P0 = find_name $S0 - $P1 = find_lex '@args' - $I1 = pop $P1 - $I0 = pop $P1 - .tailcall $P0($P1 :flat, a, b, $I0, $I1) -.end - -=back - -=cut - -# Local Variables: -# mode: pir -# fill-column: 100 -# End: -# vim: expandtab shiftwidth=4 ft=pir: diff --git a/src/old/builtins-old/system.pir b/src/old/builtins-old/system.pir deleted file mode 100644 index 7657a11dd2e..00000000000 --- a/src/old/builtins-old/system.pir +++ /dev/null @@ -1,66 +0,0 @@ -## $Id $ - -=head1 NAME - -src/builtins/system.pir - Perl6 OS-related functions - -=head1 Functions - -=over 4 - -=cut - -.namespace [] -## TODO: should these be in a namespace? -## .namespace [ '???' ] - -=item run - -our Proc::Status multi run ( ; Str $command ) -our Proc::Status multi run ( ; Str $path, *@args ) -our Proc::Status multi run ( Str @path_and_args ) - -The versions below do not return a C object, but instead -return the status code from the C opcode. - -=cut - -.sub 'run' :multi(Perl6Str) - .param string cmd - .local int retval - - '!hash_to_env'() - spawnw retval, cmd - .return (retval) -.end - -.sub 'run' :multi(Perl6Str,List) - .param string path - .param pmc args :slurpy - .local int retval - - unshift args, path - '!hash_to_env'() - spawnw retval, args - .return (retval) -.end - -.sub 'run' :multi(List) - .param pmc path_and_args - .local int retval - - '!hash_to_env'() - spawnw retval, path_and_args - .return (retval) -.end - -=back - -=cut - - -# Local Variables: -# mode: pir -# fill-column: 100 -# End: -# vim: expandtab shiftwidth=4 ft=pir: diff --git a/src/old/classes/Abstraction.pir b/src/old/classes/Abstraction.pir deleted file mode 100644 index 6e49392d203..00000000000 --- a/src/old/classes/Abstraction.pir +++ /dev/null @@ -1,22 +0,0 @@ -## $Id$ - -=head1 NAME - -src/classes/Abstraction.pir - Abstraction Role - -=head1 DESCRIPTION - -=cut - -.namespace [] - -.sub '' :anon :load :init - .local pmc abstraction - abstraction = '!create_simple_role'('Abstraction') -.end - -# Local Variables: -# mode: pir -# fill-column: 100 -# End: -# vim: expandtab shiftwidth=4 ft=pir: diff --git a/src/old/classes/Array.pir b/src/old/classes/Array.pir deleted file mode 100644 index ba2feb9d73a..00000000000 --- a/src/old/classes/Array.pir +++ /dev/null @@ -1,321 +0,0 @@ -## $Id$ - -=head1 NAME - -src/classes/Array.pir - Perl 6 Array class and related functions - -=cut - -.namespace [] -.sub '' :anon :load :init - .local pmc p6meta, arrayproto - p6meta = get_hll_global ['Perl6Object'], '$!P6META' - arrayproto = p6meta.'new_class'('Perl6Array', 'parent'=>'List', 'name'=>'Array') - arrayproto.'!MUTABLE'() - - $P0 = get_hll_namespace ['Perl6Array'] - '!EXPORT'('exists,pop,push,shift,unshift', 'from'=>$P0, 'to_p6_multi'=>1) -.end - - -=head2 Methods - -=item exists(indices :slurpy) - -Return true if the elements at C have been assigned to. - -=cut - -.namespace ['Perl6Array'] -.sub 'exists' :method :multi() :subid('array_exists') - .param pmc indices :slurpy - .local int test - - test = 0 - indices_loop: - unless indices goto indices_end - $I0 = shift indices - test = exists self[$I0] - if test goto indices_loop - indices_end: - .tailcall 'prefix:?'(test) -.end -.sub '' :init :load - .local pmc block, signature - .const 'Sub' $P0 = "array_exists" - block = $P0 - signature = allocate_signature 2 - setprop block, "$!signature", signature - null $P1 - $P0 = get_hll_global 'Array' - set_signature_elem signature, 0, "self", SIG_ELEM_INVOCANT_AND_MULTI_INVOCANT, $P0, $P1, $P1, $P1, $P1, $P1 - set_signature_elem signature, 1, "@indices", SIG_ELEM_SLURPY_POS, $P1, $P1, $P1, $P1, $P1, $P1 -.end - - -=item item() - -Return Array in item context (i.e., self) - -=cut - -.namespace ['Perl6Array'] -.sub 'item' :method - .return (self) -.end - - -=item list - -Return invocant as a List. - -=cut - -.namespace ['Perl6Array'] -.sub '' :method('list') - .tailcall self.'values'() -.end - - -=item pop() - -Remove the last item from the array and return it. - -=cut - -.sub 'pop' :method :multi() :subid('array_pop') - .local pmc x - unless self goto empty - x = pop self - goto done - empty: - x = '!FAIL'('Undefined value popped from empty array') - done: - .return (x) -.end -.sub '' :init :load - .local pmc block, signature - .const 'Sub' $P0 = "array_pop" - block = $P0 - signature = allocate_signature 1 - setprop block, "$!signature", signature - $P0 = get_hll_global 'Array' - null $P1 - set_signature_elem signature, 0, "self", SIG_ELEM_INVOCANT_AND_MULTI_INVOCANT, $P0, $P1, $P1, $P1, $P1, $P1 -.end - - -=item push(args :slurpy) - -Add C to the end of the Array. - -=cut - -.sub 'push' :method :multi() :subid('array_push') - .param pmc args :slurpy - .local pmc type, it - type = self.'of'() - args.'!flatten'() - $I1 = elements args - $I0 = 0 - it_loop: - if $I0 >= $I1 goto it_loop_end - $P0 = new ['Perl6Scalar'] - setprop $P0, 'type', type - $P1 = args[$I0] - $P0.'!STORE'($P1, 'Push') - args[$I0] = $P0 - inc $I0 - goto it_loop - it_loop_end: - $I0 = elements self - splice self, args, $I0, 0 - .return (self) -.end -.sub '' :init :load - .local pmc block, signature - .const 'Sub' $P0 = "array_push" - block = $P0 - signature = allocate_signature 2 - setprop block, "$!signature", signature - null $P1 - $P0 = get_hll_global 'Array' - set_signature_elem signature, 0, "self", SIG_ELEM_INVOCANT_AND_MULTI_INVOCANT, $P0, $P1, $P1, $P1, $P1, $P1 - set_signature_elem signature, 1, "@items", SIG_ELEM_SLURPY_POS, $P1, $P1, $P1, $P1, $P1, $P1 -.end - - -=item shift() - -Shift the first item off the array and return it. - -=cut - -.sub 'shift' :method :multi() :subid('array_shift') - .local pmc x - unless self goto empty - x = shift self - goto done - empty: - x = '!FAIL'('Undefined value shifted from empty array') - done: - .return (x) -.end -.sub '' :init :load - .local pmc block, signature - .const 'Sub' $P0 = "array_shift" - block = $P0 - signature = allocate_signature 1 - setprop block, "$!signature", signature - $P0 = get_hll_global 'Array' - null $P1 - set_signature_elem signature, 0, "self", SIG_ELEM_INVOCANT_AND_MULTI_INVOCANT, $P0, $P1, $P1, $P1, $P1, $P1 -.end - - -=item unshift(args :slurpy) - -Adds C to the beginning of the Array. - -=cut - -.sub 'unshift' :method :multi() :subid('array_unshift') - .param pmc args :slurpy - .local pmc type, it - type = self.'of'() - args.'!flatten'() - it = iter args - it_loop: - unless it goto it_loop_end - $P0 = shift it - $I0 = type.'ACCEPTS'($P0) - unless $I0 goto type_error - goto it_loop - it_loop_end: - splice self, args, 0, 0 - .return (self) - type_error: - 'die'('Type check failure in push') -.end -.sub '' :init :load - .local pmc block, signature - .const 'Sub' $P0 = "array_unshift" - block = $P0 - signature = allocate_signature 2 - setprop block, "$!signature", signature - null $P1 - $P0 = get_hll_global 'Array' - set_signature_elem signature, 0, "self", SIG_ELEM_INVOCANT_AND_MULTI_INVOCANT, $P0, $P1, $P1, $P1, $P1, $P1 - set_signature_elem signature, 1, "@items", SIG_ELEM_SLURPY_POS, $P1, $P1, $P1, $P1, $P1, $P1 -.end - -=item values() - -Return Array as a List of its values. - -=cut - -.namespace ['Perl6Array'] -.sub 'values' :method - $P0 = new ['List'] - splice $P0, self, 0, 0 - .return ($P0) -.end - -=back - -=head2 Operators - -=over - -=item circumfix:[] - -Create an array. - -=cut - -.namespace [] -.sub 'circumfix:[ ]' - .param pmc values :slurpy - .tailcall values.'Scalar'() -.end - - -=back - -=head2 Coercion methods - -=over - -=item Array - -=cut - -.namespace ['Perl6Array'] -.sub 'Array' :method - .return (self) -.end - - -=back - -=head2 Private Methods - -=over - -=item !flatten() - -Return self, as Arrays are already flattened. - -=cut - -.namespace ['Perl6Array'] -.sub '!flatten' :method - .return (self) -.end - -=item !STORE() - -Store things into an Array (e.g., upon assignment) - -=cut - -.namespace ['Perl6Array'] -.sub '!STORE' :method - .param pmc source - .local pmc array, it, type - type = self.'of'() - ## we create a new array here instead of emptying self in case - ## the source argument contains self or elements of self. - array = root_new ['parrot';'ResizablePMCArray'] - source = 'list'(source) - it = iter source - array_loop: - unless it goto array_done - $P0 = shift it - $I0 = type.'ACCEPTS'($P0) - unless $I0 goto type_error - $P0 = '!CALLMETHOD'('Scalar',$P0) - $P1 = clone $P0 - .fixup_cloned_sub($P0, $P1) - setprop $P1, 'type', type - push array, $P1 - goto array_loop - array_done: - $I0 = elements self - splice self, array, 0, $I0 - .return (self) - type_error: - $S0 = '!make_type_fail_message'('Array assignment', $P0, type) - 'die'($S0) -.end - -=back - -=cut - -# Local Variables: -# mode: pir -# fill-column: 100 -# End: -# vim: expandtab shiftwidth=4 ft=pir: diff --git a/src/old/classes/Associative.pir b/src/old/classes/Associative.pir deleted file mode 100644 index 433c4e6c6b1..00000000000 --- a/src/old/classes/Associative.pir +++ /dev/null @@ -1,130 +0,0 @@ -## $Id$ - -=head1 NAME - -src/classes/Associative.pir - Associative Role - -=head1 DESCRIPTION - -=cut - -.namespace ['Associative[::T]'] - -.sub '_associative_role_body' - .param pmc type :optional - - $P0 = get_hll_global ['Associative[::T]'], 'postcircumfix:{ }' - capture_lex $P0 - $P0 = get_hll_global ['Associative[::T]'], 'of' - capture_lex $P0 - - # Capture type. - if null type goto no_type - type = type.'WHAT'() - goto type_done - no_type: - type = get_hll_global 'Object' - type_done: - .lex 'T', type - - # Create role. - .local pmc metarole - metarole = "!meta_create"("role", "Associative[::T]", 0) - .tailcall '!create_parametric_role'(metarole) -.end -.sub '' :load :init :outer('_associative_role_body') - .local pmc block, signature - block = get_hll_global ['Associative[::T]'], '_associative_role_body' - signature = allocate_signature 1 - setprop block, "$!signature", signature - null $P1 - set_signature_elem signature, 0, "T", SIG_ELEM_IS_OPTIONAL, $P1, $P1, $P1, $P1, $P1, $P1 - "!ADDTOROLE"(block) -.end - - -=head2 Operators - -=over - -=item postcircumfix:<{ }> - -Returns a list element or slice. - -=cut - -.sub 'postcircumfix:{ }' :method :outer('_associative_role_body') - .param pmc args :slurpy - .param pmc options :slurpy :named - .local pmc result, type - type = find_lex 'T' - args.'!flatten'() - if args goto do_index - ## return complete set of values as a list - .tailcall self.'values'() - do_index: - $I0 = args.'elems'() - if $I0 != 1 goto slice - $S0 = args[0] - result = self[$S0] - unless null result goto end - result = 'undef'() - setprop result, 'type', type - self[$S0] = result - goto end - slice: - result = new ['List'] - slice_loop: - unless args goto slice_done - $S0 = shift args - .local pmc elem - elem = self[$S0] - unless null elem goto slice_elem - elem = 'undef'() - setprop elem, 'type', type - self[$S0] = elem - slice_elem: - push result, elem - goto slice_loop - slice_done: - end: - .return (result) -.end - -=item of - -Returns the type constraining what may be stored. - -=cut - -.sub 'of' :method :outer('_associative_role_body') - $P0 = find_lex 'T' - .return ($P0) -.end - -.namespace [] -.sub 'postcircumfix:{ }' - .param pmc invocant - .param pmc args :slurpy - .param pmc options :slurpy :named - $I0 = can invocant, 'postcircumfix:{ }' - if $I0 goto object_method - $I0 = isa invocant, 'Perl6Object' - if $I0 goto object_method - foreign: - $P0 = get_hll_global ['Associative[::T]'], 'postcircumfix:{ }' - .tailcall $P0(invocant, args :flat, options :flat :named) - object_method: - .tailcall invocant.'postcircumfix:{ }'(args :flat, options :flat :named) -.end - -=back - -=cut - -# Local Variables: -# mode: pir -# fill-column: 100 -# End: -# vim: expandtab shiftwidth=4 ft=pir: - diff --git a/src/old/classes/AttributeDeclarand.pir b/src/old/classes/AttributeDeclarand.pir deleted file mode 100644 index 6dc21c7ec51..00000000000 --- a/src/old/classes/AttributeDeclarand.pir +++ /dev/null @@ -1,42 +0,0 @@ -## $Id$ - -=head1 NAME - -src/classes/AttributeDeclarand.pir - Class specifying an attribute declaration - -=head1 DESCRIPTION - -This is the class that gets created and passed to a trait_mod to -describe a declaration of an attribute container in a class. - -=cut - -.namespace ['AttributeDeclarand'] - -.sub '' :anon :load :init - .local pmc p6meta - p6meta = get_hll_global ['Perl6Object'], '$!P6META' - p6meta.'new_class'('AttributeDeclarand', 'parent'=>'ContainerDeclarand', 'attr'=>'$!how') -.end - -.sub 'new' :method - .param pmc container :named('container') - .param pmc name :named('name') - .param pmc how :named('how') - $P0 = new ['AttributeDeclarand'] - setattribute $P0, '$!container', container - setattribute $P0, '$!name', name - setattribute $P0, '$!how', how - .return ($P0) -.end - -.sub 'how' :method - $P0 = getattribute self, '$!how' - .return ($P0) -.end - -# Local Variables: -# mode: pir -# fill-column: 100 -# End: -# vim: expandtab shiftwidth=4 ft=pir: diff --git a/src/old/classes/Capture.pir b/src/old/classes/Capture.pir deleted file mode 100644 index 5ee5ad4c5d8..00000000000 --- a/src/old/classes/Capture.pir +++ /dev/null @@ -1,109 +0,0 @@ -## $Id$ - -=head1 TITLE - -Capture - Perl 6 Capture class - -=head1 DESCRIPTION - -This file sets up the Perl 6 C class. - -=cut - -.namespace ['Perl6Capture'] - -.sub 'onload' :anon :init :load - .local pmc p6meta, captureproto - p6meta = get_hll_global ['Perl6Object'], '$!P6META' - captureproto = p6meta.'new_class'('Perl6Capture', 'parent'=>'parrot;Capture Any', 'name'=>'Capture') - captureproto.'!IMMUTABLE'() -.end - - -=head2 Methods - -=over 4 - -=item new - -Turns the positional arguments into the capture's positionals, and the named -arguments into the capture's nameds. - -=cut - -.sub 'new' :method - .param pmc pos_args :slurpy - .param pmc named_args :slurpy :named - - .local pmc it, result - result = new ['Perl6Capture'] - it = iter pos_args - it_pos_loop: - unless it goto it_pos_loop_end - $P0 = shift it - push result, $P0 - goto it_pos_loop - it_pos_loop_end: - it = iter named_args - it_named_loop: - unless it goto it_named_loop_end - $S0 = shift it - $P0 = named_args[$S0] - result[$S0] = $P0 - goto it_named_loop - it_named_loop_end: - - .return (result) -.end - - -=item get_string() (vtable) - -=cut - -.sub '' :vtable('get_string') :method - $S0 = self.'item'() - .return ($S0) -.end - -.sub '' :vtable('get_number') :method - $N0 = self.'item'() - .return ($N0) -.end - -.sub 'item' :method - $P0 = self[0] - unless null $P0 goto end - $P0 = 'undef'() - end: - .return ($P0) -.end - - -=back - -=head2 Operators - -=over 4 - -=item prefix:<\\> - -Build a capture from its argument(s). - -=cut - -.namespace [] -.sub 'prefix:\' - .param pmc arg - $I0 = isa arg, 'Perl6Scalar' - if $I0 goto have_ref - arg = root_new ['parrot';'Perl6Scalar'], arg - have_ref: - .return (arg) -.end - -# Local Variables: -# mode: pir -# fill-column: 100 -# End: -# vim: expandtab shiftwidth=4 ft=pir: diff --git a/src/old/classes/Code.pir b/src/old/classes/Code.pir deleted file mode 100644 index 48d7a9bab96..00000000000 --- a/src/old/classes/Code.pir +++ /dev/null @@ -1,164 +0,0 @@ -## $Id$ - -=head1 TITLE - -Code - Perl 6 Code class - -=head1 DESCRIPTION - -This file sets up the Perl 6 C class, the base class -for executable objects. - -=cut - -.namespace ['Code'] - -.sub 'onload' :anon :load :init - .local pmc p6meta, codeproto - p6meta = get_hll_global ['Perl6Object'], '$!P6META' - codeproto = p6meta.'new_class'('Code', 'parent'=>'parrot;Sub Any') - $P0 = get_hll_global 'Callable' - $P0 = $P0.'!select'() - p6meta.'add_role'($P0, 'to'=>codeproto) - codeproto.'!IMMUTABLE'() - p6meta.'register'('Sub', 'parent'=>codeproto, 'protoobject'=>codeproto) -.end - - -=item REJECTS(topic) - -=cut - -.sub 'REJECTS' :method - .param pmc topic - .local pmc match - .local pmc pgesave - match = self.'!invoke'(topic) - $P0 = getinterp - $P1 = $P0['lexpad';1] - $P1['$/'] = match - .tailcall 'prefix:!'(match) -.end - -=item assumming() - -Returns a curried version of self. - -=cut - -.sub 'assuming' :method :subid('assuming') - .param pmc args :slurpy - .param pmc named_args :slurpy :named - .local pmc curried - .lex '@args', args - .lex '%args', named_args - .lex '$obj', self - .const 'Sub' curried = 'assuming_helper' - capture_lex curried - .return (curried) -.end - -.sub 'assuming_helper' :outer('assuming') - .param pmc args :slurpy - .param pmc named_args :slurpy :named - .local pmc obj, assumed_args, assumed_named_args, result - find_lex obj, '$obj' - find_lex assumed_args, '@args' - find_lex assumed_named_args, '%args' - result = obj(assumed_args :flat, args :flat, assumed_named_args :flat :named, named_args :flat :named) - .return (result) -.end - - -=item callwith(...) - -Just calls this block with the supplied parameters. - -=cut - -.sub 'callwith' :method - .param pmc pos_args :slurpy - .param pmc named_args :slurpy :named - .tailcall self(pos_args :flat, named_args :flat :named) -.end - - -=item multi - -=cut - -.sub 'multi' :method - $P0 = get_hll_global ['Bool'], 'False' - .return ($P0) -.end - - -=item name - -=cut - -.sub 'name' :method - $S0 = self - .return ($S0) -.end - -=item perl() - -Return a response to .perl. - -=cut - -.namespace ['Code'] -.sub 'perl' :method - .return ('{ ... }') -.end - -=item signature() - -Gets the signature for the block, or returns Failure if it lacks one. - -=cut - -.sub 'signature' :method - $P0 = descalarref self - $P0 = getprop '$!signature', $P0 - if null $P0 goto no_sig - $P1 = get_hll_global 'Signature' - $P1 = $P1.'new'('ll_sig' => $P0) - .return ($P1) - no_sig: - .tailcall '!FAIL'('No signature found') -.end - - -=item !invoke - -Currently we don't have an easy way to distinguish Regex objects -from other types of Code objects, and so we have to resort to some -out-of-band mucking with PGE to get it to build Match objects. -That's the purpose of this method -- to set and restore the -type of match object that PGE regexes will create, without interfering -with the behavior of "normal" subs. - -=cut - -.sub '!invoke' :method - .param pmc topic - .local pmc pgesave, result - pgesave = get_hll_global ['PGE'], '$!MATCH' - $P0 = get_hll_global 'Match' - set_hll_global ['PGE'], '$!MATCH', $P0 - result = self(topic) - set_hll_global ['PGE'], '$!MATCH', pgesave - .return (result) -.end - -=back - -=cut - -# Local Variables: -# mode: pir -# fill-column: 100 -# End: -# vim: expandtab shiftwidth=4 ft=pir: diff --git a/src/old/classes/ContainerDeclarand.pir b/src/old/classes/ContainerDeclarand.pir deleted file mode 100644 index 6724801e5a1..00000000000 --- a/src/old/classes/ContainerDeclarand.pir +++ /dev/null @@ -1,45 +0,0 @@ -## $Id$ - -=head1 NAME - -src/classes/ContainerDeclarand.pir - Class specifying a declaration - -=head1 DESCRIPTION - -This is the class that gets created and passed to a trait_mod to -describe a declaration of a container. - -=cut - -.namespace ['ContainerDeclarand'] - -.sub '' :anon :load :init - .local pmc p6meta - p6meta = get_hll_global ['Perl6Object'], '$!P6META' - p6meta.'new_class'('ContainerDeclarand', 'parent'=>'Any', 'attr'=>'$!container $!name') -.end - -.sub 'new' :method - .param pmc container :named('container') - .param pmc name :named('name') - $P0 = new ['ContainerDeclarand'] - setattribute $P0, '$!container', container - setattribute $P0, '$!name', name - .return ($P0) -.end - -.sub 'container' :method - $P0 = getattribute self, '$!container' - .return ($P0) -.end - -.sub 'name' :method - $P0 = getattribute self, '$!name' - .return ($P0) -.end - -# Local Variables: -# mode: pir -# fill-column: 100 -# End: -# vim: expandtab shiftwidth=4 ft=pir: diff --git a/src/old/classes/Exception.pir b/src/old/classes/Exception.pir deleted file mode 100644 index ba39c864370..00000000000 --- a/src/old/classes/Exception.pir +++ /dev/null @@ -1,45 +0,0 @@ -# $Id$ - - -.namespace [ 'Perl6Exception' ] - -.sub '' :anon :init :load - .local pmc p6meta, exceptionproto - p6meta = get_hll_global ['Perl6Object'], '$!P6META' - exceptionproto = p6meta.'new_class'('Perl6Exception', 'parent'=>'Any parrot;Exception', 'attr'=>'$!exception', 'name'=>'Exception') - p6meta.'register'('Exception', 'protoobject'=>exceptionproto) -.end - -=head2 Methods - -=cut - -.sub 'resume' :method - .local pmc resume - resume = self['resume'] - resume() -.end - -.sub 'rethrow' :method - rethrow self -.end - - -.sub 'perl' :method - .return ('undef') -.end - - -.sub '' :vtable('get_string') :method - .local pmc exception - exception = getattribute self, '$!exception' - $S0 = exception['message'] - .return ($S0) -.end - - -# Local Variables: -# mode: pir -# fill-column: 100 -# End: -# vim: expandtab shiftwidth=4 ft=pir: diff --git a/src/old/classes/Failure.pir b/src/old/classes/Failure.pir deleted file mode 100644 index d6ab70ea17e..00000000000 --- a/src/old/classes/Failure.pir +++ /dev/null @@ -1,134 +0,0 @@ -# $Id$ - - -.namespace [ 'Failure' ] - -.sub '' :anon :init :load - .local pmc p6meta, failureproto - p6meta = get_hll_global ['Perl6Object'], '$!P6META' - failureproto = p6meta.'new_class'('Failure', 'parent'=>'parrot;Undef Any', 'attr'=>'$!exception') - p6meta.'register'('Undef', 'parent'=>failureproto, 'protoobject'=>failureproto) - - $P0 = box 1 - set_hll_global ['GLOBAL'], '$WARNINGS', $P0 -.end - -=head2 Methods - -=cut - -.sub 'ACCEPTS' :method - .param pmc topic - $I0 = defined topic - if $I0 goto defined - .return(1) - defined: - .return(0) -.end - - -.sub 'defined' :method - $P0 = self.'!exception'() - $P0['handled'] = 1 - $P1 = get_hll_global ['Bool'], 'False' - .return ($P1) -.end - - -.sub 'handled' :method - .local pmc exception - exception = self.'!exception'() - $I0 = exception['handled'] - .return ($I0) -.end - - -.sub 'perl' :method - .return ('undef') -.end - - -.namespace [] -.sub 'undef' - .param pmc x :slurpy - ## 0-argument test, RT#56366 - ## but see also C<< term:sym >> in STD.pm - unless x goto no_args - die "Obsolete use of undef; in Perl 6 please use undefine instead" - no_args: - $P0 = '!FAIL'() - .return ($P0) -.end - - -=head2 Private methods - -=cut - -.namespace ['Failure'] -.sub '!exception' :method - .local pmc exception - exception = getattribute self, '$!exception' - if null exception goto make_exception - $I0 = isa exception, 'Exception' - if $I0 goto have_exception - make_exception: - exception = root_new ['parrot';'Exception'] - exception['message'] = 'Use of uninitialized value' - setattribute self, '$!exception', exception - have_exception: - .return (exception) -.end - - -.sub '!throw_unhandled' :method - $I0 = self.'handled'() - if $I0 goto done - $P0 = get_hll_global ['GLOBAL'], '$WARNINGS' - unless $P0 goto done - $P0 = self.'!exception'() - $S0 = $P0['message'] - $S0 = concat $S0, "\n" - .local pmc err - err = '!find_contextual'('$*ERR') - err.'print'($S0) - done: -.end - - -=head2 Vtable functions - -=cut - -.namespace ['Failure'] -.sub '' :vtable('get_integer') :method - self.'!throw_unhandled'() - .return (0) -.end - -.sub '' :vtable('get_number') :method - self.'!throw_unhandled'() - .return (0.0) -.end - -.sub '' :vtable('get_string') :method - self.'!throw_unhandled'() - .return ('') -.end - -.sub '' :vtable('get_pmc_keyed') :method - .param pmc key - .return (self) -.end - -.sub '' :vtable('get_pmc_keyed_int') :method - .param int key - .return (self) -.end - - -# Local Variables: -# mode: pir -# fill-column: 100 -# End: -# vim: expandtab shiftwidth=4 ft=pir: diff --git a/src/old/classes/Hash.pir b/src/old/classes/Hash.pir deleted file mode 100644 index 819b3a2148f..00000000000 --- a/src/old/classes/Hash.pir +++ /dev/null @@ -1,259 +0,0 @@ -## $Id$ - -=head1 NAME - -src/classes/Hash.pir - Perl 6 Hash class and related functions - -=cut - -.namespace [] -.sub 'onload' :anon :load :init - .local pmc p6meta, hashproto - p6meta = get_hll_global ['Perl6Object'], '$!P6META' - hashproto = p6meta.'new_class'('Perl6Hash', 'parent'=>'Mapping', 'name'=>'Hash') - hashproto.'!MUTABLE'() -.end - -=head2 Methods - -=over 4 - -=cut - -=item ACCEPTS() - -=cut - -.namespace ['Perl6Hash'] -.sub '' :method :subid('hash_ACCEPTS') - .param pmc topic - .tailcall self.'contains'(topic) -.end -.sub '' :init :load - .local pmc block, signature - .const 'Sub' $P0 = "hash_ACCEPTS" - block = $P0 - signature = allocate_signature 2 - setprop block, "$!signature", signature - $P0 = get_hll_global 'Hash' - null $P1 - set_signature_elem signature, 0, "self", SIG_ELEM_INVOCANT_AND_MULTI_INVOCANT, $P0, $P1, $P1, $P1, $P1, $P1 - set_signature_elem signature, 1, "$topic", 0, $P1, $P1, $P1, $P1, $P1, $P1 -.end - - -.namespace ['Perl6Hash'] -.sub 'contains' :method :subid('hash_contains') - .param pmc key - $I0 = exists self[key] - .return( $I0 ) -.end -.sub '' :init :load - .local pmc block, signature - .const 'Sub' $P0 = "hash_contains" - block = $P0 - signature = allocate_signature 2 - setprop block, "$!signature", signature - $P0 = get_hll_global 'Hash' - null $P1 - set_signature_elem signature, 0, "self", SIG_ELEM_INVOCANT_AND_MULTI_INVOCANT, $P0, $P1, $P1, $P1, $P1, $P1 - set_signature_elem signature, 1, "$key", 0, $P1, $P1, $P1, $P1, $P1, $P1 -.end - -.namespace ['Perl6Hash'] -.sub 'delete' :method :subid('hash_delete') - .param pmc keys :slurpy - .local pmc result - .local string key - .local pmc tmp - result = new ['List'] - keys.'!flatten'() - keys_loop: - unless keys goto done - key = shift keys - tmp = self[key] - push result, tmp - delete self[key] - goto keys_loop - done: - .return (result) -.end -.sub '' :init :load - .local pmc block, signature - .const 'Sub' $P0 = "hash_delete" - block = $P0 - signature = allocate_signature 2 - setprop block, "$!signature", signature - $P0 = get_hll_global 'Hash' - null $P1 - set_signature_elem signature, 0, "self", SIG_ELEM_INVOCANT_AND_MULTI_INVOCANT, $P0, $P1, $P1, $P1, $P1, $P1 - set_signature_elem signature, 1, "@keys", SIG_ELEM_SLURPY_POS, $P1, $P1, $P1, $P1, $P1, $P1 -.end - -.namespace ['Perl6Hash'] -.sub 'exists' :method :subid('hash_exists') - .param pmc key - $I0 = exists self[key] - .return( $I0 ) -.end -.sub '' :init :load - .local pmc block, signature - .const 'Sub' $P0 = "hash_exists" - block = $P0 - signature = allocate_signature 2 - setprop block, "$!signature", signature - $P0 = get_hll_global 'Hash' - null $P1 - set_signature_elem signature, 0, "self", SIG_ELEM_INVOCANT_AND_MULTI_INVOCANT, $P0, $P1, $P1, $P1, $P1, $P1 - set_signature_elem signature, 1, "$key", 0, $P1, $P1, $P1, $P1, $P1, $P1 -.end - -.namespace ['Perl6Hash'] -.sub 'hash' :method :subid('hash_hash') - .return (self) -.end -.sub '' :init :load - .local pmc block, signature - .const 'Sub' $P0 = "hash_hash" - block = $P0 - signature = allocate_signature 1 - setprop block, "$!signature", signature - $P0 = get_hll_global 'Hash' - null $P1 - set_signature_elem signature, 0, "self", SIG_ELEM_INVOCANT_AND_MULTI_INVOCANT, $P0, $P1, $P1, $P1, $P1, $P1 -.end - -.namespace ['Perl6Hash'] -.sub 'Hash' :method :subid('hash_Hash') - .return (self) -.end -.sub '' :init :load - .local pmc block, signature - .const 'Sub' $P0 = "hash_Hash" - block = $P0 - signature = allocate_signature 1 - setprop block, "$!signature", signature - $P0 = get_hll_global 'Hash' - null $P1 - set_signature_elem signature, 0, "self", SIG_ELEM_INVOCANT_AND_MULTI_INVOCANT, $P0, $P1, $P1, $P1, $P1, $P1 -.end - -=back - -=head2 Operators - -=over - -=item circumfix:<{ }> - -Create a Hash (hashref). - -=cut - -.namespace [] -.sub 'circumfix:{ }' - .param pmc values :slurpy - $P0 = values.'Hash'() - $P0 = root_new ['parrot';'Perl6Scalar'], $P0 - .return ($P0) -.end - -=back - -=head2 Private methods - -=over - -=item !STORE - -Store a value into a hash. - -=cut - -.namespace ['Perl6Hash'] -.sub '!STORE' :method - .param pmc source - ## we create a new hash here instead of emptying self in case - ## the source argument contains self or elements of self. - .local pmc hash, it, type - hash = new ['Perl6Hash'] - - ## Need to preserve typing. - type = self.'of'() - if type == "Object" goto untyped - $P0 = get_hll_global 'Associative' - $P0 = $P0.'!select'(type) - 'infix:does'(hash, $P0) - untyped: - - source = 'list'(source) - it = iter source - iter_loop: - unless it goto iter_done - .local pmc elem, key, value - elem = shift it - $I0 = does elem, 'hash' - if $I0 goto iter_hash - $I0 = isa elem, 'Perl6Pair' - if $I0 goto iter_pair - unless it goto err_odd_list - key = elem - value = shift it - goto iter_kv - iter_pair: - key = elem.'key'() - value = elem.'value'() - iter_kv: - $I0 = type.'ACCEPTS'(value) - unless $I0 goto type_error - value = '!CALLMETHOD'('Scalar', value) - hash[key] = value - goto iter_loop - iter_hash: - .local pmc hashiter - hashiter = iter elem - hashiter_loop: - unless hashiter goto hashiter_done - $S0 = shift hashiter - value = elem[$S0] - $I0 = type.'ACCEPTS'(value) - unless $I0 goto type_error - value = '!CALLMETHOD'('Scalar', value) - value = clone value - hash[$S0] = value - goto hashiter_loop - hashiter_done: - goto iter_loop - iter_done: - copy self, hash - - # Since copy calls clone which is deep and loses properties, need to now - # re-apply type. - it = iter self - prop_set_loop: - unless it goto prop_set_loop_end - $S0 = shift it - value = self[$S0] - setprop value, 'type', type - goto prop_set_loop - prop_set_loop_end: - .return (self) - - err_odd_list: - die "Odd number of elements found where hash expected" - type_error: - $S0 = '!make_type_fail_message'('Hash assignment', value, type) - 'die'($S0) -.end - - -=back - -=cut - - -# Local Variables: -# mode: pir -# fill-column: 100 -# End: -# vim: expandtab shiftwidth=4 ft=pir: diff --git a/src/old/classes/IO.pir b/src/old/classes/IO.pir deleted file mode 100644 index f1ecaa9c8f2..00000000000 --- a/src/old/classes/IO.pir +++ /dev/null @@ -1,44 +0,0 @@ -## $Id$ - -=head1 TITLE - -IO - Perl 6 IO class - -=head1 DESCRIPTION - -This file implements the IO file handle class. - -=cut - -.namespace ['IO'] -.sub '' :anon :init :load - .local pmc p6meta - p6meta = get_hll_global ['Perl6Object'], '$!P6META' - $P0 = p6meta.'new_class'('IO', 'parent'=>'Any', 'attr'=>'$!PIO $!ins') - $P0.'!MUTABLE'() -.end - -=head2 Functions - -=over 4 - -=item C - -Gets the iterator for the IO object. - -=cut - -.namespace [] -.sub 'prefix:=' :multi('IO') - 'die'("prefix:<=> has been superseded by $handle.lines and $handle.get") -.end - -=back - -=cut - -# Local Variables: -# mode: pir -# fill-column: 100 -# End: -# vim: expandtab shiftwidth=4 ft=pir: diff --git a/src/old/classes/Iterator.pir b/src/old/classes/Iterator.pir deleted file mode 100644 index eed9901bf38..00000000000 --- a/src/old/classes/Iterator.pir +++ /dev/null @@ -1,31 +0,0 @@ -## $Id$ - -=head1 TITLE - -Iterator - Perl 6 iterator - -=head1 SUBROUTINES - -=over 4 - -=item onload - -=cut - -.namespace [] -.sub 'onload' :anon :init :load - .local pmc p6meta, iterproto - p6meta = get_hll_global ['Perl6Object'], '$!P6META' - iterproto = p6meta.'new_class'('Perl6Iterator', 'parent'=>'Any') - p6meta.'register'('Iterator', 'parent'=>iterproto, 'protoobject'=>iterproto) -.end - -=back - -=cut - -# Local Variables: -# mode: pir -# fill-column: 100 -# End: -# vim: expandtab shiftwidth=4 ft=pir: diff --git a/src/old/classes/Junction.pir b/src/old/classes/Junction.pir deleted file mode 100644 index 8bcdb145a55..00000000000 --- a/src/old/classes/Junction.pir +++ /dev/null @@ -1,532 +0,0 @@ -## $Id$ - -=head1 NAME - -src/classes/Junction.pir - Perl 6 Junction and related functions - -=cut - -# Constants for types of junctions. -.const int JUNCTION_TYPE_ANY = 1 -.const int JUNCTION_TYPE_ONE = 2 -.const int JUNCTION_TYPE_ALL = 3 -.const int JUNCTION_TYPE_NONE = 4 - -.namespace [] -.sub 'onload' :anon :load :init - .local pmc p6meta - p6meta = get_hll_global ['Perl6Object'], '$!P6META' - p6meta.'new_class'('Junction', 'parent'=>'Perl6Object', 'attr'=>'$!eigenstates $!type') -.end - -=head2 Methods - -=over 4 - -=item perl() - -Return perl representation. (This should actually be autothreaded.) - -=cut - -.namespace ['Junction'] -.sub 'perl' :method - .local int type - type = self.'!type'() - - .local string res - if type == JUNCTION_TYPE_ANY goto any - if type == JUNCTION_TYPE_ONE goto one - if type == JUNCTION_TYPE_ALL goto all - if type == JUNCTION_TYPE_NONE goto none - any: - res = 'any(' - goto type_done - one: - res = 'one(' - goto type_done - all: - res = 'all(' - goto type_done - none: - res = 'none(' - type_done: - - .local pmc it - $P0 = self.'eigenstates'() - it = iter $P0 - unless it goto states_done - $P0 = shift it - $S0 = $P0.'perl'() - concat res, $S0 - states_loop: - unless it goto states_done - $P0 = shift it - $S0 = $P0.'perl'() - concat res, ', ' - concat res, $S0 - goto states_loop - states_done: - concat res, ')' - .return (res) -.end - - -=item true() - -Evaluate Junction as a boolean. - -=cut - -.namespace ['Junction'] -.sub 'true' :method - .local pmc eigenstates, it - .local int type - eigenstates = self.'eigenstates'() - it = iter eigenstates - type = self.'!type'() - if type == JUNCTION_TYPE_NONE goto none - if type == JUNCTION_TYPE_ALL goto all - - any_one: - unless it goto false - $P0 = shift it - unless $P0 goto any_one - if type == JUNCTION_TYPE_ANY goto true - # fall through - - none: - unless it goto true - $P0 = shift it - if $P0 goto false - goto none - - all: - unless it goto true - $P0 = shift it - if $P0 goto all - # fall through - - false: - $P0 = get_hll_global ['Bool'], 'False' - .return ($P0) - - true: - $P0 = get_hll_global ['Bool'], 'True' - .return ($P0) -.end - -=item ACCEPTS - -Smart-matching for junctions, short-circuiting. - -=cut - -.namespace ['Junction'] -.sub 'ACCEPTS' :method - .param pmc topic - .local pmc eigenstates, it, state - .local int type - eigenstates = self.'eigenstates'() - it = iter eigenstates - type = self.'!type'() - if type == JUNCTION_TYPE_NONE goto none - if type == JUNCTION_TYPE_ALL goto all - any_one: - unless it goto false - state = shift it - $P0 = state.'ACCEPTS'(topic) - unless $P0 goto any_one - if type == JUNCTION_TYPE_ANY goto true - # fall through - - none: - unless it goto true - state = shift it - $P0 = state.'ACCEPTS'(topic) - if $P0 goto false - goto none - - all: - unless it goto true - state = shift it - $P0 = state.'ACCEPTS'(topic) - if $P0 goto all - - false: - $P0 = get_hll_global ['Bool'], 'False' - .return ($P0) - - true: - $P0 = get_hll_global ['Bool'], 'True' - .return ($P0) -.end - - -=item !type() - -Return the type of the Junction. - -=item eigenstates() - -Return the components of the Junction. - -=cut - -.namespace ['Junction'] -.sub '!type' :method - $P0 = getattribute self, '$!type' - .return ($P0) -.end - -.sub 'eigenstates' :method - $P0 = getattribute self, '$!eigenstates' - .return ($P0) -.end - - -=back - -=head2 VTABLE functions - -=cut - -.namespace ['Junction'] -.sub '' :method :vtable('get_bool') - $I0 = self.'true'() - .return ($I0) -.end - - -=head2 Helper functions - -=cut - -.namespace [] -.sub '!MAKE_JUNCTION' - .param pmc type - .param pmc eigenstates - - .local pmc junc - $P0 = get_hll_global 'Junction' - junc = $P0.'new'() - setattribute junc, '$!type', type - - # Make eigenstates unique if possible - if type == JUNCTION_TYPE_ONE goto set_eigenstates - $P0 = get_hll_global 'infix:===' - eigenstates = '!junction_unique_helper'(eigenstates, $P0) - set_eigenstates: - setattribute junc, '$!eigenstates', eigenstates - .return (junc) -.end - - -.sub '!junction_unique_helper' - .param pmc self - .param pmc comparer - - .local pmc ulist - ulist = root_new ['parrot';'ResizablePMCArray'] - - .local pmc it_inner, it_outer, val - it_outer = iter self - outer_loop: - unless it_outer goto outer_done - val = shift it_outer - it_inner = iter ulist - inner_loop: - unless it_inner goto inner_done - $P0 = shift it_inner - $P1 = comparer(val, $P0) - if $P1 goto outer_loop - goto inner_loop - inner_done: - ulist.'push'(val) - goto outer_loop - - outer_done: - .return (ulist) -.end - - -=over - -=item !DISPATCH_JUNCTION_CORE - -Internals to do a junctional dispatch. - -=cut - -.sub '!DISPATCH_JUNCTION_CORE' - .param pmc the_sub - .param pmc args - .param pmc name_args - - ## lookup a sub by name if needed - $I0 = isa the_sub, 'Sub' - if $I0 goto have_sub - $I0 = isa the_sub, 'MultiSub' - if $I0 goto have_sub - $S0 = the_sub - the_sub = find_name $S0 - have_sub: - - ## Look for the left-most junction. - .local int argc, index, index_save - argc = args - index = 0 - index_save = -1 - left_loop: - unless index < argc goto all_done - .local pmc junc - junc = args[index] - $I0 = isa junc, 'Junction' - if $I0 goto left_done - inc index - goto left_loop - left_done: - ## If it's an all/none junction, we're good - .local int type - type = junc.'!type'() - if type >= JUNCTION_TYPE_ALL goto have_index - ## one/any junction, so look through the remaining args for all/none - index_save = index - inc index - all_loop: - unless index < argc goto all_done - junc = args[index] - $I0 = isa junc, 'Junction' - unless $I0 goto all_next - type = junc.'!type'() - if type >= JUNCTION_TYPE_ALL goto have_index - all_next: - inc index - goto all_loop - all_done: - index = index_save - junc = args[index] - - # If we don't have a junction now, need to check for anything in named. - .local int found_junction - found_junction = isa junc, 'Junction' - unless found_junction goto check_named - type = junc.'!type'() - check_named: - .local pmc name_iter, name_junc - .local string cur_name, name_index - name_iter = iter name_args - name_loop: - unless name_iter goto name_loop_end - cur_name = shift name_iter - name_junc = name_args[cur_name] - $I0 = isa name_junc, 'Junction' - unless $I0 goto name_loop - $I0 = name_junc.'!type'() - if $I0 >= JUNCTION_TYPE_ALL goto have_named_index - if found_junction goto name_loop - have_named_index: - junc = name_junc - type = $I0 - name_index = cur_name - name_loop_end: - - have_index: - .local pmc eigenstates, it, results - eigenstates = junc.'eigenstates'() - it = iter eigenstates - results = 'list'() - thread_loop: - unless it goto thread_done - $P0 = shift it - unless null name_index goto thread_named - args[index] = $P0 - goto do_threaded_call - thread_named: - name_args[name_index] = $P0 - do_threaded_call: - $P0 = the_sub(args :flat, name_args :flat :named) - push results, $P0 - goto thread_loop - thread_done: - .tailcall '!MAKE_JUNCTION'(type, results) -.end - - -=item !DISPATCH_JUNCTION - -Does a junction dispatch. - -=cut - -.sub '!DISPATCH_JUNCTION' - .param pmc the_sub - .param pmc args :slurpy - .param pmc name_args :slurpy :named - .tailcall '!DISPATCH_JUNCTION_CORE'(the_sub, args, name_args) -.end - - -=item !DISPATCH_JUNCTION_SINGLE - -Wrapper for junction dispatcher in the single dispatch case, where we are -passed the sub that is being called along the arguments. - -=cut - -.sub '!DISPATCH_JUNCTION_SINGLE' - .param pmc sub - .param pmc capture - .local pmc pos_args, named_args - (pos_args, named_args) = '!deconstruct_call_sig'(capture) - $P0 = '!DISPATCH_JUNCTION_CORE'(sub, pos_args, named_args) - .return ($P0) -.end - - -=item !DISPATCH_JUNCTION_MULTI - -Wrapper for junction dispatcher in the multi dispatch case. Here we are handed -back as the thingy to call in place of a candidate, and PCC doesn't give us an -easy way to unshift another argument into the call, so we have it attached as -a property. - -=cut - -.sub '!DISPATCH_JUNCTION_MULTI' - .param pmc pos_args :slurpy - .param pmc name_args :slurpy :named - .local pmc pi, sub - pi = getinterp - sub = pi['sub'] - sub = getprop 'sub', sub - .tailcall '!DISPATCH_JUNCTION_CORE'(sub, pos_args, name_args) -.end - - -=item !DISPATCH_JUNCTION_METHOD - -Used to dispatch methods on a junction, where we need to auto-thread. - -=cut - -.sub '!DISPATCH_JUNCTION_METHOD' - .param pmc junc - .param pmc pos_args :slurpy - .param pmc name_args :slurpy :named - - .local string name - $P0 = getinterp - $P0 = $P0['sub'] - $P0 = getprop 'name', $P0 - name = $P0 - - .local pmc values, values_it, res, res_list, type - res_list = new ['Perl6Array'] - values = junc.'eigenstates'() - values_it = iter values - values_it_loop: - unless values_it goto values_it_loop_end - $P0 = shift values_it - res = $P0.name(pos_args :flat, name_args :flat :named) - push res_list, res - goto values_it_loop - values_it_loop_end: - type = junc.'!type'() - .const 'Sub' $P1 = '!MAKE_JUNCTION' - .tailcall $P1(type, res_list) -.end - -=back - -=head2 Functions - -=over 4 - -=item any(), infix:<|>() - -=cut - -.namespace [] -.sub 'any' - .param pmc args :slurpy - args.'!flatten'() - .tailcall '!MAKE_JUNCTION'(JUNCTION_TYPE_ANY, args) -.end - -.sub 'infix:|' - .param pmc args :slurpy - .tailcall '!MAKE_JUNCTION'(JUNCTION_TYPE_ANY, args) -.end - -=item one(), infix:<^>() - -=cut - -.namespace [] -.sub 'one' - .param pmc args :slurpy - args.'!flatten'() - .tailcall '!MAKE_JUNCTION'(JUNCTION_TYPE_ONE, args) -.end - -.sub 'infix:^' - .param pmc args :slurpy - .tailcall '!MAKE_JUNCTION'(JUNCTION_TYPE_ONE, args) -.end - - -=item all(), infix:<&>() - -=cut - -.namespace [] -.sub 'all' - .param pmc args :slurpy - args.'!flatten'() - .tailcall '!MAKE_JUNCTION'(JUNCTION_TYPE_ALL, args) -.end - -.sub 'infix:&' - .param pmc args :slurpy - .tailcall '!MAKE_JUNCTION'(JUNCTION_TYPE_ALL, args) -.end - - -=item none() - -=cut - -.namespace [] -.sub 'none' - .param pmc args :slurpy - args.'!flatten'() - .tailcall '!MAKE_JUNCTION'(JUNCTION_TYPE_NONE, args) -.end - -=item infix:<~~> - -=cut - -.sub 'infix:~~' :multi('Junction', _) - .param pmc topic - .param pmc x - $I0 = isa x, 'Junction' - unless $I0 goto not_proto_rhs - $I0 = isa x, 'P6protoobject' - if $I0 goto dispatch_on_rhs - not_proto_rhs: - .tailcall '!DISPATCH_JUNCTION'('infix:~~', topic, x) - dispatch_on_rhs: - .tailcall x.'ACCEPTS'(topic) -.end - -=back - -=cut - -# Local Variables: -# mode: pir -# fill-column: 100 -# End: -# vim: expandtab shiftwidth=4 ft=pir: diff --git a/src/old/classes/List.pir b/src/old/classes/List.pir deleted file mode 100644 index 454d23f305d..00000000000 --- a/src/old/classes/List.pir +++ /dev/null @@ -1,619 +0,0 @@ -## $Id$ - -=head1 NAME - -src/classes/List.pir - Perl 6 List class and related functions - -=cut - -.namespace [] -.sub '' :anon :load :init - .local pmc p6meta, listproto - p6meta = get_hll_global ['Perl6Object'], '$!P6META' - listproto = p6meta.'new_class'('List', 'parent'=>'parrot;ResizablePMCArray Any') - $P0 = get_hll_global 'Positional' - $P0 = $P0.'!select'() - p6meta.'add_role'($P0, 'to'=>listproto) - p6meta.'register'('ResizablePMCArray', 'parent'=>listproto, 'protoobject'=>listproto) - -.end - -=head2 Methods - -=over - -=item ACCEPTS - -Smart-matches against the list. - -=cut - -.namespace ['List'] -.sub 'ACCEPTS' :method - .param pmc topic - - # What do we have? - $I0 = isa topic, 'List' # Catches Array too - if $I0 goto array - # XXX When we have a Set type, need to handle that here too. - topic = topic.'list'() - - # Need to DWIM on *s. - array: - .local pmc it_a, it_b, cur_a, cur_b - it_a = iter self - it_b = iter topic - unless it_a goto it_loop_end - unless it_b goto it_loop_end - cur_a = shift it_a - it_loop: - unless it_b goto it_loop_end - cur_b = shift it_b - - # If there curent thing is Whatever, need special handling. - $I0 = isa cur_a, ['Whatever'] - unless $I0 goto not_whatever - - # If we don't have anything left other than the Whatever, it matches any - # ending. Otherwise, we see what we're next looking for, and keep pulling - # from the topic until we see it, or until we run out of topic in which - # case we can't get no satisfaction. - handle_whatever: - unless it_a goto true - .local pmc looking_for - looking_for = shift it_a - $I0 = isa looking_for, ['Whatever'] - if $I0 goto handle_whatever - whatever_loop: - $P0 = 'infix:==='(looking_for, cur_b) - if $P0 goto found_looking_for - unless it_b goto false - cur_b = shift it_b - goto whatever_loop - found_looking_for: - unless it_a goto it_loop_end - cur_a = shift it_a - goto it_loop - - not_whatever: - # Not whatever - check a against b, and pull another a for the next time - # around the loop, unless we've run out of b (note that if it's a whatever - # then it doesn't matter if we ran out of b; if it's not and we ran out of - # list b then we fail). - $I0 = 'infix:==='(cur_a, cur_b) - unless $I0 goto false - unless it_a goto it_loop_end - cur_a = shift it_a - $I0 = isa cur_a, ['Whatever'] - if $I0 goto handle_whatever - unless it_b goto false - goto it_loop - it_loop_end: - if it_a goto false - if it_b goto false - true: - $P0 = get_hll_global [ 'Bool' ], 'True' - .return ($P0) - false: - $P0 = get_hll_global [ 'Bool' ], 'False' - .return ($P0) -.end - - -=item item - -A List in item context becomes an Array. - -=cut - -.namespace ['List'] -.sub 'item' :method - .tailcall self.'Array'() -.end - -.namespace [] -.sub 'list' - .param pmc values :slurpy - .tailcall values.'!flatten'() -.end - - -=item !STORE(source) - -Store the values from C into C. - -=cut - -.namespace ['List'] -.sub '!STORE' :method - .param pmc source - - ## get the list of containers and sources - .local pmc list - $P0 = new ['List'] - splice $P0, self, 0, 0 - list = $P0 - source = source.'list'() - source.'!flatten'() - - ## now, go through our list of containers, flattening - ## any intermediate lists we find, and marking each - ## container with a property so we can clone it in source - ## if needed - .local pmc true - .local int i - true = box 1 - i = 0 - mark_loop: - $I0 = elements list - unless i < $I0 goto mark_done - .local pmc cont - cont = list[i] - $I0 = isa cont, ['Perl6Scalar'] - if $I0 goto mark_next - $I0 = isa cont, ['Perl6Array'] - if $I0 goto mark_next - $I0 = does cont, 'array' - unless $I0 goto mark_next - splice list, cont, $I0, 1 - goto mark_loop - mark_next: - setprop cont, 'target', true - inc i - goto mark_loop - mark_done: - - ## now build our 'real' source list, cloning any targets we encounter - .local pmc slist, it - slist = new ['List'] - it = iter source - source_loop: - unless it goto source_done - $P0 = shift it - $P1 = getprop 'target', $P0 - if null $P1 goto source_next - $P0 = clone $P0 - source_next: - push slist, $P0 - goto source_loop - source_done: - - ## now perform the assignments, clearing targets as we go - .local pmc pmcnull - null pmcnull - it = iter list - assign_loop: - unless it goto assign_done - .local pmc cont - cont = shift it - setprop cont, 'target', pmcnull - $I0 = isa cont, 'Perl6Scalar' - if $I0 goto assign_scalar - $I0 = isa cont, 'Perl6Array' - if $I0 goto assign_array - $I0 = isa cont, 'Perl6Hash' - if $I0 goto assign_hash - assign_scalar: - if slist goto have_slist - slist = new ['Nil'] - have_slist: - $P0 = shift slist - 'infix:='(cont, $P0) - goto assign_loop - assign_array: - assign_hash: - cont.'!STORE'(slist) - slist = new ['Nil'] - goto assign_loop - assign_done: - .return (list) -.end - - -=back - -=head2 Coercion methods - -=over - -=item Iterator - -=cut - -.namespace ['List'] -.sub 'Iterator' :method - self.'!flatten'() - $P0 = iter self - .return ($P0) -.end - - -=item Scalar - -A list in Scalar context becomes a Scalar containing an Array. - -=cut - -.sub 'Scalar' :method - $P0 = self.'Array'() - $P0 = root_new ['parrot';'Perl6Scalar'], $P0 - .return ($P0) -.end - -# FIXME: :vtable('get_string') is wrong here. -.sub 'Str' :method :vtable('get_string') - self.'!flatten'() - $S0 = join ' ', self - .return ($S0) -.end - -=back - -=head2 Methods - -=over - -=item elems() - -Return the number of elements in the list. - -=cut - -.namespace ['List'] -.sub 'elems' :method :multi() :vtable('get_number') :subid('list_elems') - self.'!flatten'() - $I0 = elements self - .return ($I0) -.end -.sub '' :init :load - .local pmc block, signature - .const 'Sub' $P0 = "list_elems" - block = $P0 - signature = allocate_signature 1 - setprop block, "$!signature", signature - $P0 = get_hll_global 'List' - null $P1 - set_signature_elem signature, 0, "self", SIG_ELEM_INVOCANT_AND_MULTI_INVOCANT, $P0, $P1, $P1, $P1, $P1, $P1 - '!TOPERL6MULTISUB'(block) -.end - - -=back - -=head2 Private methods - -=over 4 - -=item !flatten() - -Flatten the invocant, as in list context. This doesn't necessarily -make the list eager, it just brings any nested Lists to the top -layer. It will likely change substantially when we have lazy lists. - -=cut - -.sub '!flatten' :method - .param int size :optional - .param int has_size :opt_flag - - ## we use the 'elements' opcode here because we want the true length - .local int len, i - len = elements self - i = 0 - flat_loop: - if i >= len goto flat_end - unless has_size goto flat_loop_1 - if i >= size goto flat_end - flat_loop_1: - .local pmc elem - elem = self[i] - $I0 = isa elem, 'Perl6Scalar' - if $I0 goto flat_next - # always treat a Junction, Role and Whatever as one item, whether they can !flatten or not - # XXX this is due to C giving dubious answers due to auto-thread/pun/closure creation - $I0 = isa elem, 'Junction' - if $I0 goto flat_next - $I0 = isa elem, 'Whatever' - if $I0 goto flat_next - $I0 = isa elem, 'Perl6Role' - if $I0 goto flat_next - $I0 = isa elem, 'P6role' - if $I0 goto flat_next - $I0 = isa elem, 'MultiSub' - if $I0 goto flat_next - $I0 = can elem, '!flatten' - if $I0 goto flat_elem - $I0 = does elem, 'array' - unless $I0 goto flat_next - splice self, elem, i, 1 - len = elements self - goto flat_loop - flat_next: - inc i - goto flat_loop - flat_elem: - elem = elem.'!flatten'() - splice self, elem, i, 1 - $I0 = elements elem - i += $I0 - len = elements self - goto flat_loop - flat_end: - $I0 = isa self, 'List' - if $I0 goto end - self.'list'() - end: - .return (self) -.end - - -=item uniq(...) - -=cut - -# TODO Rewrite it. It's too naive. - -.namespace ['List'] -.sub 'uniq' :method - .param pmc comparer :optional - .param int has_comparer :opt_flag - - if has_comparer goto have_comparer - comparer = get_hll_global 'infix:eq' - have_comparer: - - .local pmc ulist - $P0 = get_hll_global 'List' - ulist = $P0.'new'() - - .local pmc it_inner, it_outer, val - it_outer = iter self - outer_loop: - unless it_outer goto outer_done - val = shift it_outer - it_inner = iter ulist - inner_loop: - unless it_inner goto inner_done - $P0 = shift it_inner - $P1 = comparer(val, $P0) - if $P1 goto outer_loop - goto inner_loop - inner_done: - ulist.'push'(val) - goto outer_loop - - outer_done: - .return (ulist) -.end - - -.namespace [] -.sub 'uniq' :multi('Block') - .param pmc comparer - .param pmc values :slurpy - values.'!flatten'() - .tailcall values.'uniq'(comparer) -.end - -.sub 'uniq' :multi() - .param pmc values :slurpy - values.'!flatten'() - .tailcall values.'uniq'() -.end - - -=back - -=head1 Functions - -=over 4 - -=item C - -Operator form for building a list from its arguments. - -=cut - -.namespace [] -.sub 'infix:,' - .param pmc args :slurpy - .tailcall args.'list'() -.end - - -=item C - -The zip operator. - -=cut - -.sub 'infix:Z' - .param pmc arglist :slurpy - .local pmc result - - # create a list to hold the results - result = new ['List'] - - unless arglist goto result_done - - # create a set of iterators, one per argument - .local pmc iterlist, arglist_it - iterlist = root_new ['parrot';'ResizablePMCArray'] - arglist_it = iter arglist - arglist_loop: - unless arglist_it goto arglist_done - .local pmc arg, arg_it - arg = shift arglist_it - arg_it = arg.'iterator'() - push iterlist, arg_it - goto arglist_loop - arglist_done: - - # repeatedly loop through the argument iterators in parallel, - # building result elements as we go. When we reach - # an argument iterator with no more elements, we're done. - - outer_loop: - .local pmc iterlist_it, reselem - iterlist_it = iter iterlist - reselem = new ['List'] - iterlist_loop: - unless iterlist_it goto iterlist_done - arg_it = shift iterlist_it - unless arg_it goto result_done - $P0 = shift arg_it - reselem.'push'($P0) - goto iterlist_loop - iterlist_done: - result.'push'(reselem) - goto outer_loop - - result_done: - .return (result) -.end - - -=item C - -The non-hyper cross operator. - -=cut - -.sub 'infix:X' - .param pmc args :slurpy - .local pmc res - - .local pmc res, outer, inner, it, val - res = new ['List'] - - ## if the are no arguments, result is empty list - unless args goto done - - ## get the first arg in list context - outer = shift args - outer = 'list'(outer) - - ## if this argument is empty, result is empty list - unless outer goto done - - ## if no more args, then build result from only arg - unless args goto one_arg - - ## There are more args, so recursively compute their cross. - ## If that list is empty, our cross is empty. - inner = 'infix:X'(args :flat) - unless inner goto done - - ## otherwise, loop through all elements of our first arg - it = iter outer - outer_loop: - unless it goto done - val = shift it - ## add the value to a clone of each inner result list - $P1 = iter inner - inner_loop: - unless $P1 goto outer_loop - ## get a result list, clone it - $P0 = shift $P1 - $P0 = clone $P0 - ## add our outer value to the beginning - unshift $P0, val - ## save it in the result list - push res, $P0 - goto inner_loop - - ## if call to infix:X had only one argument, our result - ## is a list of 1-element lists. - one_arg: - it = iter outer - one_arg_loop: - unless it goto done - val = shift it - $P0 = new ['List'] - push $P0, val - push res, $P0 - goto one_arg_loop - - done: - .return (res) -.end - - -=item C - -The min operator. - -=cut - -.sub 'infix:min' - .param pmc args :slurpy - - # If we have no arguments, undefined. - .local int elems - elems = elements args - if elems > 0 goto have_args - $P0 = root_new ['parrot';'Undef'] - .return($P0) -have_args: - - # Find minimum. - .local pmc cur_min, it - cur_min = args[0] - it = iter args -find_min_loop: - unless it goto find_min_loop_end - $P0 = shift it - $I0 = 'infix:cmp'($P0, cur_min) - unless $I0 < 0 goto find_min_loop - set cur_min, $P0 - goto find_min_loop -find_min_loop_end: - - .return(cur_min) -.end - - -=item C - -The max operator. - -=cut - -.sub 'infix:max' - .param pmc args :slurpy - - # If we have no arguments, undefined. - .local int elems - elems = elements args - if elems > 0 goto have_args - $P0 = root_new ['parrot';'Undef'] - .return($P0) -have_args: - - # Find maximum. - .local pmc cur_max, it - cur_max = args[0] - it = iter args -find_max_loop: - unless it goto find_max_loop_end - $P0 = shift it - $I0 = 'infix:cmp'($P0, cur_max) - unless $I0 > 0 goto find_max_loop - set cur_max, $P0 - goto find_max_loop -find_max_loop_end: - - .return(cur_max) -.end - -## TODO: zip - -=back - -=cut - -# Local Variables: -# mode: pir -# fill-column: 100 -# End: -# vim: expandtab shiftwidth=4 ft=pir: diff --git a/src/old/classes/Mapping.pir b/src/old/classes/Mapping.pir deleted file mode 100644 index 7183579163c..00000000000 --- a/src/old/classes/Mapping.pir +++ /dev/null @@ -1,392 +0,0 @@ -## $Id$ - -=head1 NAME - -src/classes/Mapping.pir - Perl 6 hash class and related functions - -=head1 Methods - -=cut - -.namespace ['Mapping'] - -.sub 'onload' :anon :load :init - .local pmc p6meta, mappingproto - p6meta = get_hll_global ['Perl6Object'], '$!P6META' - mappingproto = p6meta.'new_class'('Mapping', 'parent'=>'parrot;Hash Any') - $P0 = get_hll_global 'Associative' - $P0 = $P0.'!select'() - p6meta.'add_role'($P0, 'to'=>mappingproto) - p6meta.'register'('Hash', 'parent'=>mappingproto, 'protoobject'=>mappingproto) - $P0 = get_hll_namespace ['Mapping'] - '!EXPORT'('keys,kv,values', 'from'=>$P0, 'to_p6_multi'=>1) -.end - -=head2 Methods - -=over - -=item fmt - - our Str multi Mapping::fmt ( Str $format = "%s\t%s", $separator = "\n" ) - -Returns the invocant mapping formatted by an implicit call to C<.fmt> on -every pair, joined by newlines or an explicitly given separator. - -=cut - -.sub 'fmt' :method :multi() :subid('mapping_fmt') - .param string format :optional - .param int has_format :opt_flag - .param string sep :optional - .param int has_sep :opt_flag - - .local pmc it - .local pmc rv - - if has_format goto have_format - format = "%s\t%s" - - have_format: - if has_sep goto have_sep - sep = "\n" - - have_sep: - it = self.'iterator'() - rv = new ['List'] - - loop: - .local pmc pairfmt - .local pmc pair - - unless it goto end - - pair = shift it - pairfmt = pair.'fmt'(format) - - push rv, pairfmt - goto loop - - end: - rv = 'join'(sep, rv) - .return(rv) -.end -.sub '' :init :load - .local pmc block, signature - .const 'Sub' $P0 = "mapping_fmt" - block = $P0 - signature = allocate_signature 3 - setprop block, "$!signature", signature - $P0 = get_hll_global 'Mapping' - null $P1 - set_signature_elem signature, 0, "self", SIG_ELEM_INVOCANT_AND_MULTI_INVOCANT, $P0, $P1, $P1, $P1, $P1, $P1 - set_signature_elem signature, 1, "$format", SIG_ELEM_IS_OPTIONAL, $P1, $P1, $P1, $P1, $P1, $P1 - set_signature_elem signature, 2, "$sep", SIG_ELEM_IS_OPTIONAL, $P1, $P1, $P1, $P1, $P1, $P1 - '!TOPERL6MULTISUB'(block) -.end - - -=item iterator() - -=cut - -.sub 'iterator' :method :multi() :subid('mapping_iterator') - .local pmc it - .local pmc rv - - it = iter self - rv = new ['List'] - - loop: - .local string key - .local pmc pair - .local pmc val - - unless it goto end - key = shift it - val = it[key] - - pair = 'infix:=>'(key, val) - push rv, pair - goto loop - - end: - .return (rv) -.end -.sub '' :init :load - .local pmc block, signature - .const 'Sub' $P0 = "mapping_iterator" - block = $P0 - signature = allocate_signature 1 - setprop block, "$!signature", signature - $P0 = get_hll_global 'Mapping' - null $P1 - set_signature_elem signature, 0, "self", SIG_ELEM_INVOCANT_AND_MULTI_INVOCANT, $P0, $P1, $P1, $P1, $P1, $P1 - '!TOPERL6MULTISUB'(block) -.end - - -=item keys() - -Returns keys of hash as a List - -=cut - -.sub 'keys' :method :multi() :subid('mapping_keys') - .local pmc it - .local pmc rv - - it = self.'iterator'() - rv = new ['List'] - loop: - .local string key - .local pmc pair - - unless it goto end - pair = shift it - key = pair.'key'() - - push rv, key - goto loop - - end: - .return (rv) -.end -.sub '' :init :load - .local pmc block, signature - .const 'Sub' $P0 = "mapping_keys" - block = $P0 - signature = allocate_signature 1 - setprop block, "$!signature", signature - $P0 = get_hll_global 'Mapping' - null $P1 - set_signature_elem signature, 0, "self", SIG_ELEM_INVOCANT_AND_MULTI_INVOCANT, $P0, $P1, $P1, $P1, $P1, $P1 -.end - - -=item kv (method) - -Returns elements of hash as array of C - -=cut - -.sub 'kv' :method :multi() :subid('mapping_kv') - .local pmc it - .local pmc rv - - it = self.'iterator'() - rv = new ['List'] - - loop: - .local string key - .local pmc pair - .local pmc val - - unless it goto end - pair = shift it - key = pair.'key'() - val = pair.'value'() - - push rv, key - push rv, val - goto loop - - end: - .return (rv) -.end -.sub '' :init :load - .local pmc block, signature - .const 'Sub' $P0 = "mapping_kv" - block = $P0 - signature = allocate_signature 1 - setprop block, "$!signature", signature - $P0 = get_hll_global 'Mapping' - null $P1 - set_signature_elem signature, 0, "self", SIG_ELEM_INVOCANT_AND_MULTI_INVOCANT, $P0, $P1, $P1, $P1, $P1, $P1 -.end - - -=item list() - -Return invocant as a List of Pairs. - -=cut - -.sub 'list' :method - .tailcall self.'iterator'() -.end - - -=item pairs (method) - -Returns elements of hash as array of C - -=cut - -.sub 'pairs' :method :multi() :subid('mapping_pairs') - .tailcall self.'iterator'() -.end -.sub '' :init :load - .local pmc block, signature - .const 'Sub' $P0 = "mapping_pairs" - block = $P0 - signature = allocate_signature 1 - setprop block, "$!signature", signature - $P0 = get_hll_global 'Mapping' - null $P1 - set_signature_elem signature, 0, "self", SIG_ELEM_INVOCANT_AND_MULTI_INVOCANT, $P0, $P1, $P1, $P1, $P1, $P1 - '!TOPERL6MULTISUB'(block) -.end - - -=item reverse - -=cut - -.namespace ['Mapping'] -.sub 'reverse' :method :subid('mapping_reverse') - .local pmc it - .local pmc rv - - rv = new ['Perl6Hash'] - it = self.'iterator'() - - loop: - .local string key - .local pmc pair - .local pmc val - - unless it goto end - pair = shift it - key = pair.'key'() - val = pair.'value'() - - rv[val] = key - goto loop - - end: - .return (rv) -.end -.sub '' :init :load - .local pmc block, signature - .const 'Sub' $P0 = "mapping_reverse" - block = $P0 - signature = allocate_signature 1 - setprop block, "$!signature", signature - $P0 = get_hll_global 'Mapping' - null $P1 - set_signature_elem signature, 0, "self", SIG_ELEM_INVOCANT_AND_MULTI_INVOCANT, $P0, $P1, $P1, $P1, $P1, $P1 -.end - - -=item values() - -Returns values of hash as a List - -=cut - -.sub 'values' :method :multi() :subid('mapping_values') - .local pmc it - .local pmc rv - - it = self.'iterator'() - rv = new ['List'] - - loop: - .local pmc pair - .local pmc val - - unless it goto end - pair = shift it - val = pair.'value'() - - push rv, val - goto loop - - end: - .return (rv) -.end -.sub '' :init :load - .local pmc block, signature - .const 'Sub' $P0 = "mapping_values" - block = $P0 - signature = allocate_signature 1 - setprop block, "$!signature", signature - $P0 = get_hll_global 'Mapping' - null $P1 - set_signature_elem signature, 0, "self", SIG_ELEM_INVOCANT_AND_MULTI_INVOCANT, $P0, $P1, $P1, $P1, $P1, $P1 -.end - -=back - - -=head2 Coercion methods - -=over - -=item Scalar - -When we're going to be stored as an item, become a Hash and -return a Perl6Scalar with it. - -=cut - -.namespace ['Mapping'] -.sub 'Scalar' :method - $P0 = self.'Hash'() - $P0 = root_new ['parrot';'Perl6Scalar'], $P0 - .return ($P0) -.end - -=item Str - -Stringification of a Mapping - -=cut - -## FIXME: :vtable('get_string') is wrong here -.namespace ['Mapping'] -.sub 'Str' :vtable('get_string') :method - .local string rv - .local pmc it - - it = self.'iterator'() - rv = '' - loop: - .local string str - - unless it goto end - str = shift it - rv .= str - rv .= "\n" - goto loop - - end: - .return (rv) -.end - -=back - -=head2 Private methods - -=over 4 - -=item !flatten() - -Flatten the invocant, as in list context. - -=cut - -.sub '!flatten' :method - .tailcall self.'iterator'() -.end - -=back - -=cut - -# Local Variables: -# mode: pir -# fill-column: 100 -# End: -# vim: expandtab shiftwidth=4 ft=pir: diff --git a/src/old/classes/Match.pir b/src/old/classes/Match.pir deleted file mode 100644 index 66f0b46a88f..00000000000 --- a/src/old/classes/Match.pir +++ /dev/null @@ -1,72 +0,0 @@ -## $Id$ - -=head1 TITLE - -Match - Perl 6 match objects - -=head1 Description - -=cut - -.namespace ['Match'] -.sub '' :anon :load :init - .local pmc p6meta, matchproto - p6meta = get_hll_global ['Perl6Object'], '$!P6META' - matchproto = p6meta.'new_class'('Match', 'parent'=>'parrot;PGE::Grammar Any') - $P0 = p6meta.'get_parrotclass'(matchproto) - $P1 = root_new ['parrot';'ResizablePMCArray'] - push $P1, 'of' - $P0.'resolve_method'($P1) - $P0 = get_hll_global 'Positional' - $P0 = $P0.'!select'() - p6meta.'add_role'($P0, 'to'=>matchproto) - $P0 = get_hll_global 'Associative' - $P0 = $P0.'!select'() - p6meta.'add_role'($P0, 'to'=>matchproto) -.end - - -=item hash, list - -Currently C interposes its own C and C methods -on Match objects, these force Match.hash and Match.list to -properly delegate to the underlying Capture PMC. - -=cut - -.sub '' :method('item') - .return (self) -.end - -.sub '' :method('hash') - $P0 = getattribute self, ['Capture'], 'proxy' - $P1 = $P0.'hash'() - .return ($P1) -.end - -.sub '' :method('list') - $P0 = getattribute self, ['Capture'], 'proxy' - $P1 = $P0.'list'() - .return ($P1) -.end - - -=item of - -Returns the type of value that this Match object may store. Note: we need this -to resolve role composition collision with Positional and Associative. At some -point we may not have of there, but for now it's the best place. - -=cut - -.sub 'of' :method - $P0 = get_hll_global 'Object' - .return ($P0) -.end - - -# Local Variables: -# mode: pir -# fill-column: 100 -# End: -# vim: expandtab shiftwidth=4 ft=pir: diff --git a/src/old/classes/Module.pir b/src/old/classes/Module.pir deleted file mode 100644 index 126e93f9bbd..00000000000 --- a/src/old/classes/Module.pir +++ /dev/null @@ -1,49 +0,0 @@ -## $Id$ - -=head1 TITLE - -Code - Perl 6 Module class - -=head1 DESCRIPTION - -This file sets up the Perl 6 C class. - -=cut - -.namespace ['Module'] - -.sub 'onload' :anon :load :init - .local pmc p6meta, moduleproto - p6meta = get_hll_global ['Perl6Object'], '$!P6META' - moduleproto = p6meta.'new_class'('Module', 'parent'=>'parrot;NameSpace Any') - p6meta.'register'('NameSpace', 'parent'=>moduleproto, 'protoobject'=>moduleproto) -.end - - -=head1 METHODS - -=over 4 - -=item WHAT - -Gets the proto-object for this module. - -=cut - -.sub 'WHAT' :method - # The usual approach of .WHAT doesn't work for us here, because get_class - # is overridden in the NameSpace PMC. - $P0 = get_hll_global 'Module' - .return ($P0) -.end - - -=back - -=cut - -# Local Variables: -# mode: pir -# fill-column: 100 -# End: -# vim: expandtab shiftwidth=4 ft=pir: diff --git a/src/old/classes/Multi.pir b/src/old/classes/Multi.pir deleted file mode 100644 index 83b902badbf..00000000000 --- a/src/old/classes/Multi.pir +++ /dev/null @@ -1,47 +0,0 @@ -## $Id$ - -=head1 TITLE - -Multi - Perl 6 multi-dispatch routine - -=head1 SUBROUTINES - -=over 4 - -=item onload() - -=cut - -.namespace [ 'Multi' ] - -.sub 'onload' :anon :init :load - .local pmc p6meta, proto - p6meta = get_hll_global ['Perl6Object'], '$!P6META' - proto = p6meta.'new_class'('Multi', 'parent'=>'parrot;Perl6MultiSub Code Any') - p6meta.'register'('Perl6MultiSub', 'parent'=>proto, 'protoobject'=>proto) - p6meta.'register'('MultiSub', 'parent'=>proto, 'protoobject'=>proto) -.end - -=item multi - -=cut - -.sub 'multi' :method - $P0 = get_hll_global ['Bool'], 'True' - .return ($P0) -.end - -.sub 'Scalar' :method - .return (self) -.end - - -=back - -=cut - -# Local Variables: -# mode: pir -# fill-column: 100 -# End: -# vim: expandtab shiftwidth=4 ft=pir: diff --git a/src/old/classes/Nil.pir b/src/old/classes/Nil.pir deleted file mode 100644 index fe596b8ef78..00000000000 --- a/src/old/classes/Nil.pir +++ /dev/null @@ -1,87 +0,0 @@ -## $Id$ - -=head1 NAME - -src/classes/Nil.pir - Nil objects - -=head1 DESCRIPTION - -=cut - -.namespace [] - -.sub '' :anon :load :init - .local pmc p6meta, nilproto - p6meta = get_hll_global ['Perl6Object'], '$!P6META' - nilproto = p6meta.'new_class'('Nil', 'parent'=>'Failure') -.end - -=head2 Methods - -=over - -=item 'list' - -=cut - -.namespace ['Nil'] -.sub 'list' :method :subid('') - $P0 = new ['List'] - .return ($P0) -.end - - -=item 'shift' - -=cut - -.namespace ['Nil'] -.sub 'shift' :method :vtable('shift_pmc') - .return (self) -.end - -=back - -=head2 Coercion methods - -=over - -=item Scalar - -=cut - -.namespace ['Nil'] -.sub 'Scalar' :method - $P0 = '!FAIL'() - .return ($P0) -.end - - -=back - -=head2 Private methods - -=over - -=item !flatten - -Return an empty list when flattened. - -=cut - -.namespace ['Nil'] -.sub '!flatten' :method - .tailcall self.'list'() -.end - - -=back - -=cut - -# Local Variables: -# mode: pir -# fill-column: 100 -# End: -# vim: expandtab shiftwidth=4 ft=pir: - diff --git a/src/old/classes/Object.pir b/src/old/classes/Object.pir deleted file mode 100644 index e40ab125783..00000000000 --- a/src/old/classes/Object.pir +++ /dev/null @@ -1,957 +0,0 @@ -## $Id$ - -=head1 TITLE - -Object - Perl 6 Object class - -=head1 DESCRIPTION - -This file sets up the base classes and methods for Perl 6's -object system. Differences (and conflicts) between Parrot's -object model and the Perl 6 model means we have to do a little -name and method trickery here and there, and this file takes -care of much of that. - -=cut - -# A few useful constants (just here so they're available going forward). -.const int SIG_ELEM_SLURPY_POS = 8 -.const int SIG_ELEM_SLURPY_NAMED = 16 -.const int SIG_ELEM_SLURPY = 56 -.const int SIG_ELEM_INVOCANT = 64 -.const int SIG_ELEM_MULTI_INVOCANT = 128 -.const int SIG_ELEM_INVOCANT_AND_MULTI_INVOCANT = 192 -.const int SIG_ELEM_IS_RW = 256 -.const int SIG_ELEM_IS_COPY = 512 -.const int SIG_ELEM_IS_REF = 1024 -.const int SIG_ELEM_IS_OPTIONAL = 2048 - -=head2 Methods - -=over 4 - -=item clone() - -Returns a copy of the object. - -NOTE: Don't copy what this method does; it's a tad inside-out. We should be -overriding the clone vtable method to call .clone() really. But if we do that, -we can't current get at the Object PMC's clone method, so for now we do it -like this. - -=cut - -.macro fixup_cloned_sub(orig, copy) - .local pmc tmp, tmp2 - tmp = getprop '$!signature', .orig - if null tmp goto sub_fixup_done - setprop .copy, '$!signature', tmp - .local pmc oclass, sclass - oclass = typeof .orig - sclass = get_class ['Sub'] - $I0 = issame oclass, sclass - if $I0 goto sub_fixup_done - tmp = getattribute .orig, ['Sub'], 'proxy' - tmp = getprop '$!real_self', tmp - if null tmp goto sub_fixup_done - tmp2 = getattribute .copy, ['Sub'], 'proxy' - setprop tmp2, '$!real_self', tmp - sub_fixup_done: -.endm - -.namespace ['Perl6Object'] -.sub 'clone' :method - .param pmc new_attrs :slurpy :named - - # Make a clone. - .local pmc result - self = deobjectref self - result = clone self - - # Set any new attributes. - .local pmc p6meta, parrotclass, attributes, it - p6meta = get_hll_global ['Perl6Object'], '$!P6META' - parrotclass = p6meta.'get_parrotclass'(result) - if null parrotclass goto attrinit_done - attributes = inspect parrotclass, 'attributes' - it = parrotclass.'attriter'() - attrinit_loop: - unless it goto attrinit_done - .local string attrname, shortname - attrname = shift it - shortname = substr attrname, 2 - $I0 = exists new_attrs[shortname] - unless $I0 goto attrinit_loop - $P0 = getattribute result, attrname - $P1 = new_attrs[shortname] - 'infix:='($P0, $P1) - goto attrinit_loop - attrinit_done: - - .fixup_cloned_sub(self, result) - .return (result) -.end - - -=item defined() - -Return true if the object is defined. - -=cut - -.namespace ['Perl6Object'] -.sub 'defined' :method - $P0 = get_hll_global ['Bool'], 'True' - .return ($P0) -.end - - -=item hash - -Return invocant in hash context. - -=cut - -.namespace ['Perl6Object'] -.sub 'hash' :method - .tailcall self.'Hash'() -.end - -.namespace [] -.sub 'hash' - .param pmc values :slurpy - .tailcall values.'Hash'() -.end - -=item item - -Return invocant in item context. Default is to return self. - -=cut - -.namespace ['Perl6Object'] -.sub 'item' :method - .return (self) -.end - -.namespace [] -.sub 'item' - .param pmc x :slurpy - $I0 = elements x - unless $I0 == 1 goto have_x - x = shift x - have_x: - $I0 = can x, 'item' - unless $I0 goto have_item - x = x.'item'() - have_item: - .return (x) -.end - - -=item iterator - -=cut - -.namespace ['Perl6Object'] -.sub 'iterator' :method - $P0 = self.'list'() - .tailcall $P0.'iterator'() -.end - - -=item list - -Return invocant in list context. Default is to return a List containing self. - -=cut - -.namespace ['Perl6Object'] -.sub '' :method('list') - $P0 = new ['List'] - push $P0, self - .return ($P0) -.end - -=item print() - -Print the object. - -=cut - -.namespace ['Perl6Object'] -.sub 'print' :method - $P0 = get_hll_global 'print' - .tailcall $P0(self) -.end - -=item say() - -Print the object, followed by a newline. - -=cut - -.namespace ['Perl6Object'] -.sub 'say' :method - $P0 = get_hll_global 'say' - .tailcall $P0(self) -.end - -=item true() - -Boolean value of object -- defaults to C<.defined> (S02). - -=cut - -.namespace ['Perl6Object'] -.sub 'true' :method - .tailcall self.'defined'() -.end - -=back - -=head2 Coercion methods - -=over 4 - -=item Array() - -=cut - -.namespace ['Perl6Object'] -.sub 'Array' :method - $P0 = new ['Perl6Array'] - $P0.'!STORE'(self) - .return ($P0) -.end - -=item Hash() - -=cut - -.namespace ['Perl6Object'] -.sub 'Hash' :method - $P0 = new ['Perl6Hash'] - $P0.'!STORE'(self) - .return ($P0) -.end - -=item Iterator() - -=cut - -.sub 'Iterator' :method - $P0 = self.'list'() - .tailcall $P0.'Iterator'() -.end - -=item Scalar() - -Default Scalar() gives reference type semantics, returning -an object reference (unless the invocant already is one). - -=cut - -.namespace ['Perl6Object'] -.sub 'Scalar' :method - $I0 = isa self, 'Perl6Scalar' - unless $I0 goto not_ref - .return (self) - not_ref: - $P0 = root_new ['parrot';'Perl6Scalar'], self - .return ($P0) -.end - -=item Str() - -Return a string representation of the invocant. Default is -the object's type and address. - -=cut - -.namespace ['Perl6Object'] -.sub 'Str' :method - $P0 = root_new ['parrot';'ResizableStringArray'] - $P1 = self.'WHAT'() - push $P0, $P1 - $I0 = get_addr self - push $P0, $I0 - $S0 = sprintf "%s<0x%x>", $P0 - .return ($S0) -.end - -=back - -=head2 Object constructor methods - -=over 4 - -=cut - -.namespace ['Perl6Object'] -.sub 'bless' :method - .param pmc candidate - .param pmc posargs :slurpy - .param pmc attrinit :slurpy :named - - $I0 = isa candidate, 'Whatever' - unless $I0 goto have_candidate - candidate = self.'CREATE'('P6opaque') - have_candidate: - - .tailcall self.'BUILDALL'(candidate, attrinit, posargs) -.end - - -.sub 'BUILD' :method - .param pmc attrinit :slurpy :named - - .local pmc p6meta, parentproto, parrotclass, attributes, it - p6meta = get_hll_global ['Perl6Object'], '$!P6META' - parentproto = find_caller_lex '$CLASS' - parrotclass = p6meta.'get_parrotclass'(parentproto) - attributes = inspect parrotclass, 'attributes' - it = parrotclass.'attriter'() - attrinit_loop: - unless it goto attrinit_done - .local string attrname, keyname - .local pmc attr, attrhash - attrname = shift it - attr = getattribute self, parrotclass, attrname - attrhash = attributes[attrname] - $I0 = index attrname, '!' - if $I0 < 0 goto attrinit_loop - inc $I0 - keyname = substr attrname, $I0 - $P0 = attrinit[keyname] - unless null $P0 goto attrinit_assign - $P0 = attrhash['init_value'] - if null $P0 goto attrinit_loop - $P0 = $P0(self, attr) - attrinit_assign: - 'infix:='(attr, $P0) - goto attrinit_loop - attrinit_done: - .return (self) -.end - - -.sub 'BUILDALL' :method - .param pmc candidate - .param pmc attrinit - .param pmc posargs - - .include 'iterator.pasm' - .local pmc p6meta, parents, it - p6meta = get_hll_global ['Perl6Object'], '$!P6META' - $P0 = p6meta.'get_parrotclass'(self) - parents = inspect $P0, 'all_parents' - it = iter parents - set it, .ITERATE_FROM_END - parents_loop: - # Loop through all of the parent classes, in reverse mro. - # For each parent class, call its BUILD method with the - # appropriate arguments. - unless it goto parents_done - $P0 = pop it - $I0 = isa $P0, 'PMCProxy' - if $I0 goto parents_loop - .local pmc parentproto - $P0 = getprop 'metaclass', $P0 - parentproto = $P0.'WHAT'() - $I0 = can parentproto, 'BUILD' - unless $I0 goto parents_loop - .lex '$CLASS', parentproto - # Look through posargs for a corresponding protoobject - # with a WHENCE property. If found, that WHENCE property - # is used as the arguments to the parent class BUILD. - .local pmc pos_it, argproto - pos_it = iter posargs - posargs_loop: - unless pos_it goto posargs_done - argproto = shift pos_it - $P1 = argproto.'HOW'() - ne_addr $P0, $P1, posargs_loop - $P0 = argproto.'WHENCE'() - if null $P0 goto posargs_done - $P1 = find_method parentproto, 'BUILD' - $P1(candidate, $P0 :flat :named) - goto parents_loop - posargs_done: - $P1 = find_method parentproto, 'BUILD' - $P1(candidate, attrinit :flat :named) - goto parents_loop - parents_done: - .return (candidate) -.end - - -=item CREATE() - -Create a candidate object of the type given by the invocant. - -XXX This had probably best really just tailcall .^CREATE; move this stuff later. - -=cut - -.sub 'CREATE' :method - .param string repr :optional - .param int have_repr :opt_flag - - # Default to P6opaque. - if have_repr goto repr_done - repr = 'P6opaque' - repr_done: - - # If we already have an "example" of how this representation looks for the - # current class, just clone it. - .local pmc how - .local string repr_lookup - how = self.'HOW'() - repr_lookup = concat 'repr_', repr - $P0 = getprop repr_lookup, how - if null $P0 goto no_example - $P0 = clone $P0 - .return ($P0) - - no_example: - if repr != 'P6opaque' goto unknown_repr - - # P6opaque. Create example. - .local pmc p6meta, parrot_class, example - p6meta = get_hll_global ['Perl6Object'], '$!P6META' - parrot_class = p6meta.'get_parrotclass'(self) - example = new parrot_class - - # Set up attribute containers along with their types and any other - # traits. (We could do this while constructing the class too, but - # that would have the unfortunate side-effect of increased startup - # cost, which we're currently wanting to avoid. Let's see how far - # we can go while doing the init here.) - .local pmc parents, cur_class, attributes, class_it, it, traits - parents = inspect parrot_class, 'all_parents' - class_it = iter parents - classinit_loop: - unless class_it goto classinit_loop_end - cur_class = shift class_it - attributes = inspect cur_class, 'attributes' - it = cur_class.'attriter'() - attrinit_loop: - unless it goto attrinit_done - .local string attrname - .local pmc attrhash, itypeclass - attrname = shift it - $I0 = index attrname, '!' - if $I0 < 0 goto attrinit_loop - attrhash = attributes[attrname] - itypeclass = attrhash['itype'] - $S0 = substr attrname, 0, 1 - unless null itypeclass goto attrinit_itype - if $S0 == '@' goto attrinit_array - if $S0 == '%' goto attrinit_hash - $P0 = get_root_namespace ['parrot';'Perl6Scalar'] - itypeclass = get_class $P0 - goto attrinit_itype - attrinit_array: - itypeclass = get_class ['Perl6Array'] - goto attrinit_itype - attrinit_hash: - itypeclass = get_class ['Perl6Hash'] - attrinit_itype: - .local pmc attr - attr = new itypeclass - setattribute example, cur_class, attrname, attr - traits = attrhash['traits'] - if null traits goto traits_done - $P0 = getprop 'metaclass', cur_class - if null $P0 goto traits_done - traits(attr, $P0) - traits_done: - goto attrinit_loop - attrinit_done: - # Only go to next class if we didn't already reach the top of the Perl 6 - # hierarchy. - $S0 = cur_class - if $S0 != 'Perl6Object' goto classinit_loop - classinit_loop_end: - - # Turn the example from a Parrot Object into a p6opaque; we'll ideally be - # able to create it as one in the future. - transform_to_p6opaque example - - # Stash the example, clone it and we're done. - setprop how, repr_lookup, example - $P0 = clone example - .return ($P0) - - unknown_repr: - 'die'('Unknown representation: ', repr) -.end - - -=item new() - -Create a new object having the same class as the invocant. - -=cut - -.sub 'new' :method - .param pmc posargs :slurpy - .param pmc attrinit :slurpy :named - .local pmc candidate - candidate = self.'CREATE'('P6opaque') - .tailcall self.'bless'(candidate, posargs :flat, attrinit :flat :named) -.end - -=item 'PARROT' - -Report the object's true nature. - -=cut - -.sub 'PARROT' :method - .local pmc obj - .local string result - obj = self - result = '' - deref_loop: - $I0 = isa obj, 'ObjectRef' - unless $I0 goto deref_done - $I0 = isa obj, 'Perl6Scalar' - if $I0 goto deref_scalar - result .= 'ObjectRef->' - goto deref_next - deref_scalar: - result .= 'Perl6Scalar->' - deref_next: - obj = deref obj - goto deref_loop - deref_done: - $P0 = typeof obj - $S0 = $P0 - result .= $S0 - .return (result) -.end - - -=item REJECTS(topic) - -Define REJECTS methods for objects (this would normally -be part of the Pattern role, but we put it here for now -until we get roles). - -=cut - -.sub 'REJECTS' :method - .param pmc topic - $P0 = self.'ACCEPTS'(topic) - $P1 = not $P0 - .return ($P1) -.end - - -=item !STORE(source) - -Store C into C, performing type checks -as needed. (This method is listed with the other public -methods simply because I expect it may switch to public -in the future.) - -=cut - -.sub '!STORE' :method :subid('Object::!STORE') - .param pmc source - .param string typeerr :optional - .param int has_typeerr :opt_flag - source = '!CALLMETHOD'('Scalar', source) - $I0 = defined source - unless $I0 goto do_store - .local pmc type - getprop type, 'type', self - if null type goto do_store - $I0 = isa type, 'NameSpace' - if $I0 goto do_store - $I0 = type.'ACCEPTS'(source) - unless $I0 goto err_type - do_store: - source = deobjectref source - eq_addr self, source, store_done - copy self, source - .fixup_cloned_sub(source, self) - store_done: - .return (self) - - err_type: - if has_typeerr goto have_typeerr - typeerr = 'Assignment' - have_typeerr: - $S0 = '!make_type_fail_message'(typeerr, source, type) - 'die'($S0) -.end - - -=item WHENCE() - -Return the invocant's auto-vivification closure. - -=cut - -.sub 'WHENCE' :method - $P0 = self.'WHAT'() - $P1 = $P0.'WHENCE'() - .return ($P1) -.end - - -=item WHERE - -Gets the memory address of the object. - -=cut - -.sub 'WHERE' :method - $I0 = get_addr self - .return ($I0) -.end - - -=item WHICH - -Gets the object's identity value - -=cut - -.sub 'WHICH' :method - # For normal objects, this can just be the memory address. - .tailcall self.'WHERE'() -.end - -=back - -=head2 Private methods - -=over 4 - -=item !cloneattr(attrlist) - -Create a clone of self, also cloning the attributes given by attrlist. - -=cut - -.namespace ['Perl6Object'] -.sub '!cloneattr' :method - .param string attrlist - .local pmc p6meta, result - p6meta = get_hll_global ['Perl6Object'], '$!P6META' - $P0 = p6meta.'get_parrotclass'(self) - result = new $P0 - - .local pmc attr_it - attr_it = split ' ', attrlist - attr_loop: - unless attr_it goto attr_end - $S0 = shift attr_it - unless $S0 goto attr_loop - $P1 = getattribute self, $S0 - if null $P1 goto null_attr - $P1 = clone $P1 - null_attr: - setattribute result, $S0, $P1 - goto attr_loop - attr_end: - .return (result) -.end - - -=item !rebox - -If we end up with an object that isn't a subclass of Perl6Object -(e.g., a parrot Integer, Float, or Str), the C method will -adjust it. - -=cut - -.namespace ['Perl6Object'] -.sub '!rebox' :method - $I0 = isa self, ['Perl6Object'] - if $I0 goto done - .local pmc p6meta - p6meta = get_hll_global ['Perl6Object'], '$!P6META' - $P0 = self.'WHAT'() - $P0 = p6meta.'get_parrotclass'($P0) - $P0 = new $P0 - assign $P0, self - copy self, $P0 - done: -.end - - -=item !.? - -Helper method for implementing the .? operator. Calls at most one matching -method, and returns undef if there are none. - -=cut - -.sub '!.?' :method - .param pmc call_sig :call_sig - .local pmc methods - .local string method_name - self = shift call_sig - methods = shift call_sig - method_name = shift call_sig - unshift call_sig, self - - # Deconstruct call signature (no caller side :call_sig yet). - .local pmc pos_args, named_args - (pos_args, named_args) = '!deconstruct_call_sig'(call_sig) - - # If we were already given a list, just check it's non-empty and use that. - if null methods goto no_list - retry: - $I0 = elements methods - unless $I0 goto error - $P0 = methods[0] - $I0 = isa $P0, 'Perl6MultiSub' - unless $I0 goto ready_to_call - $P0 = $P0.'find_possible_candidates'(call_sig) - $P0 = $P0[0] - unless null $P0 goto ready_to_call - $P0 = shift methods - goto retry - ready_to_call: - .tailcall $P0(pos_args :flat, named_args :named :flat) - - # If there's no list, use .can to try and get us one. - no_list: - $P0 = self.'HOW'() - $P0 = $P0.'can'(self, method_name) - unless $P0 goto error - push_eh check_error - .tailcall $P0(pos_args :flat, named_args :named :flat) - check_error: - .local pmc exception - .get_results (exception) - pop_eh - if exception == "No candidates found to invoke" goto error - rethrow exception - - error: - .tailcall '!FAIL'('Undefined value returned by invocation of undefined method') -.end - - -=item !.* - -Helper method for implementing the .* operator. Calls one or more matching -methods. - -=cut - -.sub '!.*' :method - .param pmc call_sig :call_sig - .local pmc methods - .local string method_name - self = shift call_sig - methods = shift call_sig - method_name = shift call_sig - unshift call_sig, self - - # Deconstruct call signature (no caller side :call_sig yet). - .local pmc pos_args, named_args - (pos_args, named_args) = '!deconstruct_call_sig'(call_sig) - - # Set up result list. - .local pmc result_list - $P0 = get_hll_global 'list' - result_list = $P0() - - # Get all possible methods, unless we already were given a list. - unless null methods goto have_methods - $P0 = self.'HOW'() - methods = $P0.'can'(self, method_name) - unless methods goto it_loop_end - have_methods: - # Call each method, expanding out any multis along the way. - .local pmc pos_res, named_res, cap, it, multi_it, cur_meth - it = iter methods - it_loop: - unless it goto it_loop_end - cur_meth = shift it - $P0 = cur_meth - $I0 = isa $P0, 'P6Invocation' - unless $I0 goto did_deref - $P0 = deref cur_meth - did_deref: - $I0 = isa $P0, 'Perl6MultiSub' - if $I0 goto is_multi - push_eh check_error - (pos_res :slurpy, named_res :named :slurpy) = cur_meth(pos_args :flat, named_args :named :flat) - pop_eh - cap = 'prefix:\'(pos_res :flat, named_res :flat :named) - push result_list, cap - goto it_loop - is_multi: - $P0 = $P0.'find_possible_candidates'(call_sig) - multi_it = iter $P0 - multi_it_loop: - unless multi_it goto it_loop - cur_meth = shift multi_it - (pos_res :slurpy, named_res :named :slurpy) = cur_meth(pos_args :flat, named_args :named :flat) - cap = 'prefix:\'(pos_res :flat, named_res :flat :named) - push result_list, cap - goto multi_it_loop - check_error: - .local pmc exception - .get_results (exception) - pop_eh - if exception == "No candidates found to invoke" goto it_loop - rethrow exception - it_loop_end: - - .return (result_list) -.end - - -=item !.+ - -Helper method for implementing the .+ operator. Calls one or more matching -methods, dies if there are none. - -=cut - -.sub '!.+' :method - .param pmc methods - .param string method_name - .param pmc pos_args :slurpy - .param pmc named_args :slurpy :named - - # Use !.* to produce a (possibly empty) list of result captures. - .local pmc result_list - result_list = self.'!.*'(methods, method_name, pos_args :flat, named_args :flat :named) - - # If we got no elements at this point, we must die. - $I0 = elements result_list - if $I0 == 0 goto failure - .return (result_list) - failure: - $S0 = "Could not invoke method '" - concat $S0, method_name - concat $S0, "' on invocant of type '" - $S1 = self.'WHAT'() - concat $S0, $S1 - concat $S0, "'" - 'die'($S0) -.end - - -=item !.^ - -Helper for doing calls on the metaclass. - -=cut - -.sub '!.^' :method - .param pmc method - .param string method_name - .param pmc pos_args :slurpy - .param pmc named_args :slurpy :named - - # Get the HOW or the object and do the call on that. - .local pmc how - how = self.'HOW'() - if null method goto by_name - .tailcall '!dispatch_method_indirect'(how, method, self, pos_args :flat, named_args :flat :named) - by_name: - .tailcall how.method_name(self, pos_args :flat, named_args :flat :named) -.end - - -=item !.= - -Helper for doing .= calls. - -=cut - -.sub '!.=' :method - .param pmc method - .param string method_name - .param pmc pos_args :slurpy - .param pmc named_args :slurpy :named - - # Get result and assign it to self. (XXX Also while $/ is not accessed - # as a context var properly, need to cheat bit with that to keep - # some other things happy.) - $P0 = find_lex_skip_current '$/' - .lex '$/', $P0 - if null method goto by_name - $I0 = elements method - if $I0 != 1 goto too_many_methods - method = method[0] - ($P0) = self.method(pos_args :flat, named_args :flat :named) - goto called - by_name: - ($P0) = self.method_name(pos_args :flat, named_args :flat :named) - called: - $P1 = getinterp - $P1 = $P1['lexpad'; 1] - if null $P1 goto done - $P1['$/'] = $P0 - done: - .tailcall 'infix:='(self, $P0) - too_many_methods: - 'die'('.= indirect form can only be used to supply a single method') -.end - -=back - -=head2 Vtable functions - -=cut - -.namespace ['Perl6Object'] -.sub '' :vtable('decrement') :method - $P0 = self.'pred'() - 'infix:='(self, $P0) - .return(self) -.end - -.sub '' :vtable('defined') :method - $I0 = self.'defined'() - .return ($I0) -.end - -.sub '' :vtable('get_bool') :method - $I0 = self.'true'() - .return ($I0) -.end - -.sub '' :vtable('get_integer') :method - .tailcall self.'Int'() -.end - -.sub '' :vtable('get_iter') :method - .tailcall self.'Iterator'() -.end - -.sub '' :vtable('get_string') :method - $S0 = self.'Str'() - .return ($S0) -.end - -.sub '' :vtable('get_number') :method - $N0 = self.'Num'() - .return ($N0) -.end - -.sub '' :vtable('increment') :method - $P0 = self.'succ'() - 'infix:='(self, $P0) - .return(self) -.end - -# Local Variables: -# mode: pir -# fill-column: 100 -# End: -# vim: expandtab shiftwidth=4 ft=pir: diff --git a/src/old/classes/Order.pir b/src/old/classes/Order.pir deleted file mode 100644 index 023ac61e4ec..00000000000 --- a/src/old/classes/Order.pir +++ /dev/null @@ -1,58 +0,0 @@ -## $Id$ - -=head1 TITLE - -Bool - Perl 6 boolean class - -=head1 DESCRIPTION - -This file sets up the Perl 6 C class, and initializes -symbols for C, C, and C. - -Note that one we have true Perl 6 enums this file will probably -disappear and the definition moved into a prelude. - -=cut - -.namespace ['Order'] - -.sub 'onload' :anon :init :load - .local pmc p6meta, orderproto - p6meta = get_hll_global ['Perl6Object'], '$!P6META' - orderproto = p6meta.'new_class'('Order', 'parent'=>'Int') - - $P0 = orderproto.'new'() - $P0 = 0 - set_hll_global ['Order'], 'Same', $P0 - - $P0 = orderproto.'new'() - $P0 = 1 - set_hll_global ['Order'], 'Decrease', $P0 - - $P0 = orderproto.'new'() - $P0 = -1 - set_hll_global ['Order'], 'Increase', $P0 - - # Mark as enum elements. - $P0 = class $P0 - $P1 = box 1 - setprop $P0, 'enum', $P1 -.end - - -.sub 'perl' :method - if self < 0 goto increase - if self > 0 goto decrease - .return ('Order::Same') - increase: - .return ('Order::Increase') - decrease: - .return ('Order::Decrease') -.end - - -# Local Variables: -# mode: pir -# fill-column: 100 -# End: -# vim: expandtab shiftwidth=4 ft=pir: diff --git a/src/old/classes/Pair.pir b/src/old/classes/Pair.pir deleted file mode 100644 index 5815b6afd1d..00000000000 --- a/src/old/classes/Pair.pir +++ /dev/null @@ -1,89 +0,0 @@ -## $Id$ - -=head1 NAME - -src/classes/Pair.pir - methods for the Pair class - -=head1 Methods - -=over 4 - -=cut - -.namespace ['Perl6Pair'] - -.sub 'onload' :anon :load :init - .local pmc p6meta, pairproto - p6meta = get_hll_global ['Perl6Object'], '$!P6META' - pairproto = p6meta.'new_class'('Perl6Pair', 'parent'=>'Any', 'attr'=>'$!key $!value', 'name'=>'Pair') - pairproto.'!IMMUTABLE'() -.end - - -=item key - -Gets the key of the pair. - -=cut -.sub 'key' :method - $P0 = getattribute self, '$!key' - .return ($P0) -.end - - -=item get_string() (vtable method) - -Stringify the Pair. - -=cut - -.sub 'get_string' :method :vtable - $S0 = self.'key'() - concat $S0, "\t" - $S1 = self.'value'() - concat $S0, $S1 - .return ($S0) -.end - - -.namespace [] - -.sub 'infix:=>' - .param pmc key - .param pmc value - key = key.'item'() - value = value.'item'() - $P0 = new ['Perl6Pair'] - $P1 = root_new ['parrot';'Perl6Scalar'] - 'infix:='($P1, key) - setattribute $P0, '$!key', $P1 - setattribute $P0, '$!value', value - .return ($P0) -.end - - -.sub 'infix:cmp' :multi(['Perl6Pair'], ['Perl6Pair']) - .param pmc a - .param pmc b - $P0 = a.'key'() - $P1 = b.'key'() - $I0 = 'infix:cmp'($P0, $P1) - unless $I0 == 0 goto done - $P0 = a.'value'() - $P1 = b.'value'() - $I0 = 'infix:cmp'($P0, $P1) - done: - $P0 = 'infix:<=>'($I0, 0) - .return ($P0) -.end - - -=back - -=cut - -# Local Variables: -# mode: pir -# fill-column: 100 -# End: -# vim: expandtab shiftwidth=4 ft=pir: diff --git a/src/old/classes/Range.pir b/src/old/classes/Range.pir deleted file mode 100644 index 46266ab52cf..00000000000 --- a/src/old/classes/Range.pir +++ /dev/null @@ -1,290 +0,0 @@ -## $Id$ - -=head1 NAME - -src/classes/Range.pir - methods for the Range class - -=head1 DESCRIPTION - -=cut - -.namespace ['Range'] - -.sub '' :anon :load :init - .local pmc p6meta, rangeproto - p6meta = get_hll_global ['Perl6Object'], '$!P6META' - rangeproto = p6meta.'new_class'('Range', 'parent'=>'Any', 'attr'=>'$!by $!from $!to $!from_exclusive $!to_exclusive') - - $P0 = p6meta.'get_parrotclass'(rangeproto) - $P1 = root_new ['parrot';'ResizablePMCArray'] - push $P1, 'postcircumfix:[ ]' - $P0.'resolve_method'($P1) - $P0 = get_hll_global 'Positional' - $P0 = $P0.'!select'() - p6meta.'add_role'($P0, 'to'=>rangeproto) - - rangeproto.'!IMMUTABLE'() -.end - -=head2 Methods - -=over 4 - -=item list() - -Generate the Range in list context. Currently we generate all -of the elements in the range; when we have lazy lists we can -just return a clone of the Range. - -=cut - -.sub '' :method('list') - .local pmc range_it, result - range_it = self.'iterator'() - result = new ['List'] - range_loop: - unless range_it goto range_end - $P0 = shift range_it - push result, $P0 - goto range_loop - range_end: - .return (result) -.end - - -=item pop() (vtable_method) - -Generate the next element at the end of the Range. - -=cut - -.namespace ['Range'] -.sub 'pop' :method :vtable('pop_pmc') - .local pmc to, toexc, value - to = getattribute self, '$!to' - toexc = getattribute self, '$!to_exclusive' - value = 'postfix:--'(to) - unless toexc goto have_value - value = clone to - have_value: - $I0 = self.'!from_test'(value) - if $I0 goto success - value = '!FAIL'('Undefined value popped from empty range') - success: - .return (value) -.end - - -=item postcircumfix:[ ] - -=cut - -.sub 'postcircumfix:[ ]' :method - .param pmc pos_args :slurpy - .param pmc named_args :slurpy :named - # Since ranges aren't lazy yet anyway, we just get the .list() for - # this range and then delegate to it's postcircumfix. When they are - # truly lazy we can re-visit this and do something smarter. - $P0 = self.'list'() - .tailcall $P0.'postcircumfix:[ ]'(pos_args :flat, named_args :flat :named) -.end -.sub '' :vtable('elements') - $I0 = self.'elems'() - .return ($I0) -.end - - -=item shift() (vtable_method) - -Generate the next element at the front of the Range. - -=cut - -.sub 'shift' :method :vtable('shift_pmc') - .local pmc from, fromexc, value - from = getattribute self, '$!from' - fromexc = getattribute self, '$!from_exclusive' - value = 'postfix:++'(from) - unless fromexc goto have_value - value = from.'clone'() - have_value: - $I0 = self.'!to_test'(value) - if $I0 goto success - value = '!FAIL'('Undefined value shifted from empty range') - success: - .return (value) -.end - - -=back - -=head2 Operators - -=over 4 - -=item infix:<..> - -=item infix:<^..> - -=item infix:<..^> - -=item infix:<^..^> - -Construct a range from the endpoints. - -=cut - -.namespace [] -.sub 'infix:..' :multi() - .param pmc from - .param pmc to - .local pmc proto - proto = get_hll_global 'Range' - .tailcall proto.'new'('from'=>from, 'to'=>to) -.end - -.sub 'infix:^..' :multi() - .param pmc from - .param pmc to - .local pmc proto, true - proto = get_hll_global 'Range' - true = get_hll_global ['Bool'], 'True' - .tailcall proto.'new'('from'=>from, 'to'=>to, 'from_exclusive'=>true) -.end - -.sub 'infix:..^' :multi() - .param pmc from - .param pmc to - .local pmc proto, true - proto = get_hll_global 'Range' - true = get_hll_global ['Bool'], 'True' - .tailcall proto.'new'('from'=>from, 'to'=>to, 'to_exclusive'=>true) -.end - -.sub 'infix:^..^' :multi() - .param pmc from - .param pmc to - .local pmc proto, true - proto = get_hll_global 'Range' - true = get_hll_global ['Bool'], 'True' - .tailcall proto.'new'('from'=>from, 'to'=>to, 'from_exclusive'=>true, 'to_exclusive'=>true) -.end - -=item prefix:<^>(Any $to) - -Construct a Range from C< 0 ..^ $to >. - -=cut - -.namespace[] -.sub 'prefix:^' :multi(_) - .param num to - .tailcall 'infix:..^'(0, to) -.end - -=item prefix:<^>(Type $x) - -Return $x.HOW. - -=cut - -.sub 'prefix:^' :multi('P6Protoobject') - .param pmc proto - .tailcall proto.'HOW'() -.end - -=back - -=head2 Private methods - -=over 4 - -=item !flatten() - -=cut - -.namespace ['Range'] -.sub '!flatten' :method - .tailcall self.'list'() -.end - -=item !from_test(topic) - -=item !to_test(topic) - -Returns true if C is greater than C<.from> / less than C<.to>, -honoring exclusive flags. - -=cut - -.namespace ['Range'] -.sub '!from_test' :method - .param pmc topic - .local pmc from, fromexc - from = getattribute self, '$!from' - fromexc = getattribute self, '$!from_exclusive' - if fromexc goto exclusive_test - $I0 = isge topic, from - .return ($I0) - exclusive_test: - $I0 = isgt topic, from - .return ($I0) -.end - -.sub '!to_test' :method - .param pmc topic - .local pmc to, toexc - to = getattribute self, '$!to' - $I0 = isa to, 'String' - unless $I0 goto test_value - $S0 = topic - $I0 = length $S0 - $S1 = to - $I1 = length $S1 - eq $I0, $I1, test_value - $I0 = islt $I0, $I1 - .return ($I0) - test_value: - toexc = getattribute self, '$!to_exclusive' - if toexc goto exclusive_test - $I0 = isle topic, to - .return ($I0) - exclusive_test: - $I0 = islt topic, to - .return ($I0) -.end - -=back - -=head2 Vtable functions - -=over - -=item VTABLE_get integer (vtable method) - -=item VTABLE_get_number (vtable method) - -=cut - -.sub '' :method :vtable('get_integer') - $P0 = self.'list'() - $I0 = $P0 - .return ($I0) -.end - -.sub '' :method :vtable('get_number') - $P0 = self.'list'() - $N0 = $P0 - .return ($N0) -.end - -=back - -=cut - -# Local Variables: -# mode: pir -# fill-column: 100 -# End: -# vim: expandtab shiftwidth=4 ft=pir: - diff --git a/src/old/classes/Regex.pir b/src/old/classes/Regex.pir deleted file mode 100644 index 323c7133782..00000000000 --- a/src/old/classes/Regex.pir +++ /dev/null @@ -1,99 +0,0 @@ -## $Id$ - -=head1 TITLE - -Regex - Perl 6 Regex class - -=head1 DESCRIPTION - -This file sets up the Perl 6 C class, the class for regexes. - -=cut - -.namespace ['Regex'] - -.sub 'onload' :anon :load :init - .local pmc p6meta - p6meta = get_hll_global ['Perl6Object'], '$!P6META' - p6meta.'new_class'('Regex', 'parent'=>'Routine') -.end - -=over 4 - -=item ACCEPTS - -=cut - -.sub 'ACCEPTS' :method - .param pmc topic - .local pmc match - - # If topic is an Array or Hash, need special treatment. - $I0 = isa topic, 'Perl6Array' - if $I0 goto is_array - $I0 = isa topic, 'Perl6Hash' - if $I0 goto is_hash - goto is_match - - # Hash - just get keys and fall through to array case. - is_hash: - topic = topic.'keys'() - - # Array - try matching against each entry. In future, can probably - # let junction dispatcher handle this for us. - is_array: - .local pmc it - it = iter topic - it_loop: - unless it goto it_loop_end - $P0 = shift it - match = self.'!invoke'($P0) - if match goto store_match - goto it_loop - it_loop_end: - match = '!FAIL'('no matches') - goto store_match - - # Otherwise, just match on the topic. - is_match: - match = self.'!invoke'(topic) - - store_match: - # Store match object in $/. - push_eh not_regex - $P0 = getinterp - $P1 = $P0['lexpad';1] - $P2 = root_new ['parrot';'Perl6Scalar'], match - $P1['$/'] = $P2 - not_regex: - .return (match) -.end - - -=item true() - -Evaluate a Regex in boolean context -- i.e., perform a match -against $_. - -=cut - -.sub '' :method('true') - $P0 = find_caller_lex '$_' - $P3 = self($P0) - .tailcall 'prefix:?'($P3) -.end - -.sub '' :vtable('get_bool') :method - $I0 = self.'true'() - .return ($I0) -.end - -=back - -=cut - -# Local Variables: -# mode: pir -# fill-column: 100 -# End: -# vim: expandtab shiftwidth=4 ft=pir: diff --git a/src/old/classes/Routine.pir b/src/old/classes/Routine.pir deleted file mode 100644 index 9ace4870dd2..00000000000 --- a/src/old/classes/Routine.pir +++ /dev/null @@ -1,37 +0,0 @@ -## $Id$ - -=head1 TITLE - -Code - Perl 6 Routine class - -=head1 DESCRIPTION - -This file sets up the Perl 6 C class, the base class for all -wrappable executable objects. - -=cut - -.include 'interpinfo.pasm' - -.namespace ['Routine'] - -.sub 'onload' :anon :load :init - .local pmc p6meta - p6meta = get_hll_global ['Perl6Object'], '$!P6META' - p6meta.'new_class'('Routine', 'parent'=>'Block') -.end - - -=head1 METHODS - -=over 4 - -=back - -=cut - -# Local Variables: -# mode: pir -# fill-column: 100 -# End: -# vim: expandtab shiftwidth=4 ft=pir: diff --git a/src/old/classes/Signature.pir b/src/old/classes/Signature.pir deleted file mode 100644 index e092bc423de..00000000000 --- a/src/old/classes/Signature.pir +++ /dev/null @@ -1,124 +0,0 @@ -## $Id$ - -=head1 TITLE - -Signature - Perl 6 Signature class - -=head1 DESCRIPTION - -This file sets up the high level Perl 6 C class. It wraps around a -P6LowLevelSig and provides higher level access to it. - -=cut - -.namespace ['Signature'] - -.sub 'onload' :anon :init :load - load_bytecode 'PCT.pbc' - .local pmc p6meta - p6meta = get_hll_global ['Perl6Object'], '$!P6META' - p6meta.'new_class'('Signature', 'parent'=>'Any', 'attr'=>'$!ll_sig') -.end - - -=head2 Methods - -=over 4 - -=item params - -Returns a C of C descriptors. - -=cut - -.sub 'params' :method - # Create result. - .local pmc result - result = new 'ResizablePMCArray' - - # Grab low level signature we're wrapping. - .local pmc signature - signature = getattribute self, '$!ll_sig' - signature = descalarref signature - - # And Parameter proto. - .local pmc parameter - parameter = get_hll_global 'Parameter' - - # Loop over parameters. - .local int cur_param, count - count = get_signature_size signature - cur_param = -1 - param_loop: - inc cur_param - unless cur_param < count goto param_done - - # Get all curent parameter info. - .local pmc nom_type, cons_type, names, type_captures, default, sub_sig - .local int flags, optional, invocant, multi_invocant, slurpy, rw, ref, copy, named - .local string name - get_signature_elem signature, cur_param, name, flags, nom_type, cons_type, names, type_captures, default, sub_sig - optional = flags & SIG_ELEM_IS_OPTIONAL - invocant = flags & SIG_ELEM_INVOCANT - multi_invocant = flags & SIG_ELEM_MULTI_INVOCANT - slurpy = flags & SIG_ELEM_SLURPY - rw = flags & SIG_ELEM_IS_RW - ref = flags & SIG_ELEM_IS_REF - copy = flags & SIG_ELEM_IS_COPY - - # Make sure constraints is non-null. - unless null cons_type goto have_cons - cons_type = get_hll_global ['Bool'], 'True' - goto cons_done - have_cons: - cons_type = 'infix:&'(cons_type :flat) - cons_done: - - # Any names? - named = 0 - if null names goto no_names - named = 1 - names = 'list'(names :flat) - goto names_done - no_names: - names = 'list'() - $I0 = flags & SIG_ELEM_SLURPY_NAMED - unless $I0 goto names_done - named = 1 - names_done: - - # Any type captures? - if null type_captures goto no_type_captures - type_captures = 'list'(type_captures :flat) - goto type_captures_done - no_type_captures: - type_captures = 'list'() - type_captures_done: - - # Make sure default and sub-signature are non-null. - unless null default goto default_done - default = 'undef'() - default_done: - unless null sub_sig goto sub_sig_done - sub_sig = 'undef'() - sub_sig_done: - - # Create parameter instance. - $P0 = parameter.'new'('name'=>name, 'type'=>nom_type, 'constraints'=>cons_type, 'optional'=>optional, 'slurpy'=>slurpy, 'invocant'=>invocant, 'multi_invocant'=>multi_invocant, 'rw'=>rw, 'ref'=>ref, 'copy'=>copy, 'named'=>named, 'named_names'=>names, 'type_captures'=>type_captures, 'default'=>default, 'signature'=>sub_sig) - push result, $P0 - goto param_loop - param_done: - - # Turn into a List. - .tailcall 'list'(result :flat) -.end - -=back - -=cut - -# Local Variables: -# mode: pir -# fill-column: 100 -# End: -# vim: expandtab shiftwidth=4 ft=pir: diff --git a/src/old/classes/Submethod.pir b/src/old/classes/Submethod.pir deleted file mode 100644 index 7bc23c76758..00000000000 --- a/src/old/classes/Submethod.pir +++ /dev/null @@ -1,31 +0,0 @@ -## $Id$ - -=head1 TITLE - -Submethod - Perl 6 Submethod class - -=head1 DESCRIPTION - -This file sets up the Perl 6 C class, the class for submethods. - -=cut - -.namespace ['Submethod'] - -.sub 'onload' :anon :load :init - .local pmc p6meta - p6meta = get_hll_global ['Perl6Object'], '$!P6META' - p6meta.'new_class'('Submethod', 'parent'=>'Routine') -.end - -=over 4 - -=back - -=cut - -# Local Variables: -# mode: pir -# fill-column: 100 -# End: -# vim: expandtab shiftwidth=4 ft=pir: diff --git a/src/old/classes/Whatever.pir b/src/old/classes/Whatever.pir deleted file mode 100644 index f2dfc2fcdb9..00000000000 --- a/src/old/classes/Whatever.pir +++ /dev/null @@ -1,25 +0,0 @@ -## $Id$ - -=head1 TITLE - -Whatever - Perl 6 Whatever class - -=head1 DESCRIPTION - -This file implements the Whatever class. - -=cut - -.namespace ['Whatever'] - -.sub 'onload' :anon :init :load - .local pmc p6meta, whateverproto - p6meta = get_hll_global ['Perl6Object'], '$!P6META' - whateverproto = p6meta.'new_class'('Whatever', 'parent'=>'Failure') -.end - -# Local Variables: -# mode: pir -# fill-column: 100 -# End: -# vim: expandtab shiftwidth=4 ft=pir: diff --git a/src/old/classes/WhateverCode.pir b/src/old/classes/WhateverCode.pir deleted file mode 100644 index db13ddd3e50..00000000000 --- a/src/old/classes/WhateverCode.pir +++ /dev/null @@ -1,77 +0,0 @@ -## $Id$ - -=head1 TITLE - -WhateverCode - Blocks that delay evaluation of whatever results - -=head1 DESCRIPTION - -This file sets up the Perl 6 C class, the class for -C operations. - -=cut - -.namespace ['WhateverCode'] - -.sub 'onload' :anon :load :init - .local pmc p6meta - p6meta = get_hll_global ['Perl6Object'], '$!P6META' - p6meta.'new_class'('WhateverCode', 'parent'=>'Code') -.end - - -.namespace [] -.sub 'WhateverCodeX' :anon - .param string opname - .param pmc left - .param pmc right :optional - .local pmc opfunc - opfunc = find_name opname - .lex '$opfunc', opfunc - .lex '$left', left - .lex '$right', right - .const 'Sub' $P0 = '!whatever_closure' - $P1 = newclosure $P0 - '!fixup_routine_type'($P1, 'WhateverCode') - .return ($P1) -.end -.sub '!whatever_closure' :anon :outer('WhateverCodeX') - .param pmc arg - .local pmc opfunc, left, right - opfunc = find_lex '$opfunc' - left = find_lex '$left' - right = find_lex '$right' - left = '!whatever_eval'(left, arg) - if null right goto unary - right = '!whatever_eval'(right, arg) - .tailcall opfunc(left, right) - unary: - .tailcall opfunc(left) -.end -.sub '!whatever_eval' :multi(_) - .param pmc whatever - .param pmc arg - .return (whatever) -.end -.sub '!whatever_eval' :multi('Whatever') - .param pmc whatever - .param pmc arg - .return (arg) -.end -.sub '!whatever_eval' :multi('WhateverCode') - .param pmc whatever - .param pmc arg - .tailcall whatever(arg) -.end - -=over 4 - -=back - -=cut - -# Local Variables: -# mode: pir -# fill-column: 100 -# End: -# vim: expandtab shiftwidth=4 ft=pir: diff --git a/src/old/parrot/P6Invocation.pir b/src/old/parrot/P6Invocation.pir deleted file mode 100644 index bf79cfc015c..00000000000 --- a/src/old/parrot/P6Invocation.pir +++ /dev/null @@ -1,39 +0,0 @@ -## $Id$ - -=head1 NAME - -src/parrot/P6Invocation - extra methods for the P6Invocation PMC - -=head2 Methods on P6Invocation - -We also add some methods to P6Invocation. - -=item !flatten - -Here so that list(...) will behave nicely. No doubt can change substantially -when we have laziness support. - -=cut - -.namespace ["P6Invocation"] -.sub '!flatten' :method - .local pmc result - result = new ['ResizablePMCArray'] - it_loop: - unless self goto it_loop_end - $P0 = shift self - push result, $P0 - goto it_loop - it_loop_end: - .return (result) -.end - -=back - -=cut - -# Local Variables: -# mode: pir -# fill-column: 100 -# End: -# vim: expandtab shiftwidth=4 ft=pir: diff --git a/src/old/parrot/misc.pir b/src/old/parrot/misc.pir deleted file mode 100644 index dda9a4eca1a..00000000000 --- a/src/old/parrot/misc.pir +++ /dev/null @@ -1,104 +0,0 @@ -=item ResizablePMCArray.list - -This version of list morphs a ResizablePMCArray into a List. - -=cut - -.namespace ['ResizablePMCArray'] -.sub 'list' :method :subid('') - ## this code morphs a ResizablePMCArray into a List - ## without causing a clone of any of the elements - $P0 = new 'ResizablePMCArray' - splice $P0, self, 0, 0 - $P1 = new 'List' - copy self, $P1 - splice self, $P0, 0, 0 - .return (self) -.end - - -## special method to cast Parrot String into Rakudo Str. -.namespace ['String'] -.sub 'Scalar' :method - $P0 = new 'Str' - assign $P0, self - copy self, $P0 - .return (self) -.end - - -=item count() - -Return the number of required and optional parameters for a Block. -Note that we currently do this by adding the method to Parrot's -"Sub" PMC, so that it works for non-Rakudo subs. - -=cut - -.namespace ['Sub'] -.sub 'count' :method - $P0 = inspect self, "pos_required" - $P1 = inspect self, "pos_optional" - add $P0, $P1 - .return ($P0) -.end - - -.namespace [] -# work around a parrot bug. -.sub 'load-language' - .param string lang - load_language lang -.end - - -# Twiddle MultiSub - at most of these can go away when it stops inheriting -# from RPA. - -.namespace ['MultiSub'] - -.sub 'Scalar' :method - .return (self) -.end - -.sub 'perl' :method - .return ('{ ... }') -.end - -=item name - -Gets the name of the routine. - -=cut - -.sub 'name' :method - # We'll just use the name of the first candidate. - $S0 = '' - $P0 = self[0] - if null $P0 goto done - $S0 = $P0 - done: - .return ($S0) -.end - - -=item Class.attriter - -Return an iterator that iterates over a Class' attributes. -If the Class object has a @!attribute_list property, use -that as the order of attributes, otherwise introspect the -class and use its list. (As of Parrot 1.4.0 we can't -always introspect the class directly, as the order of -attributes in the class isn't guaranteed.) - -=cut - -.namespace ['Class'] -.sub 'attriter' :method - $P0 = getprop '@!attribute_list', self - unless null $P0 goto have_list - $P0 = inspect self, 'attributes' - have_list: - $P1 = iter $P0 - .return ($P1) -.end diff --git a/src/old/parrot/signature.pir b/src/old/parrot/signature.pir deleted file mode 100644 index f595a4841a4..00000000000 --- a/src/old/parrot/signature.pir +++ /dev/null @@ -1,22 +0,0 @@ -# Copyright (C) 2007-2009, The Perl Foundation. - -=head1 NAME - -signature.pir - a plug-in to the PAST::Compiler for signatures - -=head1 DESCRIPTION - -This adds another multi-variant so when we see a Perl6::Compiler::Signature -in the PAST tree, we know what to do with it. This prevents us from having -to make sure we emit code to build the signature. - -=cut - -.include "interpinfo.pasm" -.namespace [ 'PAST';'Compiler' ] -.sub 'as_post' :method :multi(_, ['Perl6';'Compiler';'Signature']) - .param pmc node - .param pmc options :slurpy :named - node = node.'ast'() - .tailcall self.'as_post'(node, options :flat :named) -.end diff --git a/src/old/parrot/state.pir b/src/old/parrot/state.pir deleted file mode 100644 index 3dabe59f43d..00000000000 --- a/src/old/parrot/state.pir +++ /dev/null @@ -1,79 +0,0 @@ -# Copyright (C) 2007-2009, The Perl Foundation. - -=head1 NAME - -state.pir - supports the state scope type - -=head1 DESCRIPTION - -This is a kind of "plug-in" to PAST::Compiler that adds the state scope type. -This may or may not get folded back into PCT some day. - -XXX TODO: Doesn't yet handle binding beyond the initial one. - -=cut - -.include "interpinfo.pasm" -.namespace [ 'PAST';'Compiler' ] -.sub 'state' :method :multi(_, ['PAST';'Var']) - .param pmc node - .param pmc bindpost - - .local string name - $P0 = get_hll_global ['POST'], 'Ops' - name = node.'name'() - name = self.'escape'(name) - - .local int isdecl - isdecl = node.'isdecl'() - - if bindpost goto lexical_bind - - lexical_post: - if isdecl goto lexical_decl - .local pmc ops, fetchop, storeop - ops = $P0.'new'('node'=>node) - $P0 = get_hll_global ['POST'], 'Op' - fetchop = $P0.'new'(ops, name, 'pirop'=>'find_lex') - storeop = $P0.'new'(name, ops, 'pirop'=>'store_lex') - .tailcall self.'vivify'(node, ops, fetchop, storeop) - - lexical_decl: - ops = $P0.'new'('node'=>node) - - # Do a call to restore any previous values. We can skip the rest - # if it returns a false value. - $P0 = self.'uniquereg'('I') - ops.'push_pirop'('call', '"!state_var_inited"', name, 'result'=>$P0) - $P1 = get_hll_global ['POST'], 'Label' - $S0 = self.'unique'('state') - $P1 = $P1.'new'('result'=>$S0) - ops.'push_pirop'('if', $P0, $P1) - - # Vivify and store vivification. - .local pmc viviself, vivipost - viviself = node.'viviself'() - vivipost = self.'as_vivipost'(viviself, 'rtype'=>'P') - ops.'push'(vivipost) - ops.'push_pirop'('.lex', name, vivipost) - $P0 = self.'uniquereg'('P') - ops.'push_pirop'('interpinfo', $P0, .INTERPINFO_CURRENT_SUB) - ops.'push_pirop'('getprop', $P0, '"$!state_store"', $P0) - $S0 = $P0 - concat $S0, "[" - concat $S0, name - concat $S0, "]" - ops.'push_pirop'('set', $S0, vivipost) - ops.'result'(vivipost) - - # Finally, label we go to if we don't need to init. - ops.'push'($P1) - .return (ops) - - lexical_bind: - $P0 = get_hll_global ['POST'], 'Op' - if isdecl goto lexical_bind_decl - .tailcall $P0.'new'(name, bindpost, 'pirop'=>'store_lex', 'result'=>bindpost) - lexical_bind_decl: - .tailcall $P0.'new'(name, bindpost, 'pirop'=>'.lex', 'result'=>bindpost) -.end diff --git a/src/old/parser/actions.pm b/src/old/parser/actions.pm deleted file mode 100644 index 6b5a760c6af..00000000000 --- a/src/old/parser/actions.pm +++ /dev/null @@ -1,3515 +0,0 @@ -# Copyright (C) 2007-2009, The Perl Foundation. -# $Id$ - -class Perl6::Grammar::Actions ; - -# The %?CLASSMAP hash is used to identify those classes where we -# "lie" about the class name in order to work around RT #43419 / TT #71. -# When those are fixed and we can use the "true" Perl 6 classnames, -# this can be removed. (See also the C method below.) -our %?CLASSMAP; -%?CLASSMAP := 'Perl6Object'; -%?CLASSMAP := 'Perl6Array'; -%?CLASSMAP := 'Perl6Hash'; -%?CLASSMAP := 'Perl6Pair'; - -# $?RAKUDO_HLL identifies the .HLL to use for compilation -- -# it's ultimately set by the .RAKUDO_HLL macro in F . -our $?RAKUDO_HLL; - -method TOP($/) { - my $past := $.ast; - $past.blocktype('declaration'); - $past.hll($?RAKUDO_HLL); - declare_implicit_routine_vars($past); - $past.lexical(0); - - # Make sure we have the interpinfo constants. - $past.unshift( PAST::Op.new( :inline('.include "interpinfo.pasm"') ) ); - # Set package for unit mainline - $past.unshift(set_package_magical()); - - # Create the unit's startup block, unless it's suppressed. - our $?SUPPRESS_MAIN; - my $main; - our @?BLOCK; - if $?SUPPRESS_MAIN { - $past.push(PAST::Stmts.new()); - $main := $past; - } - elsif +@?BLOCK && @?BLOCK[0] == 1 { - $past.blocktype('immediate'); - $past.lexical(1); - @?BLOCK[0].push($past); - $main := @?BLOCK[0]; - } - else { - $main := PAST::Block.new( :pirflags(':main') ); - $main.loadinit().push( - PAST::Op.new( :inline('$P0 = compreg "perl6"', - 'unless null $P0 goto have_perl6', - 'load_bytecode "perl6.pbc"', - 'have_perl6:') - ) - ); - - # call the unit mainline, passing any arguments, and return - # the result. We force a tailcall here because we need a - # :load sub (below) to occur last in the generated output, but don't - # want it to be treated as the module's return value. - $main.push( - PAST::Op.new( :pirop('tailcall'), - PAST::Op.new( :pirop('find_name'), '!UNIT_START' ), - $past, - PAST::Var.new( :scope('parameter'), :name('@_'), :slurpy(1) ) - ) - ); - - # generate a :load sub that invokes this one, but does so _last_ - # (e.g., at the end of a load_bytecode operation) - $main.push( - PAST::Block.new( :pirflags(':load'), :blocktype('declaration'), - PAST::Op.new( - :inline( '.include "interpinfo.pasm"', - '$P0 = interpinfo .INTERPINFO_CURRENT_SUB', - '$P0 = $P0."get_outer"()', - '$P0()' - ) - ) - ) - ); - $main.push( PAST::Stmts.new() ); - } - - $main.hll($?RAKUDO_HLL); - my $?FILE := Q:PIR { %r = find_caller_lex '$?FILES' }; - $main.unshift(PAST::Op.new(:inline(".annotate 'file', '" ~ $?FILE ~ "'"))); - make $main; -} - - -method statement_block($/, $key) { - our @?BLOCK; - our $?BLOCK_OPEN; - ## when entering a block, use any $?BLOCK_OPEN if it exists, - ## otherwise create an empty block with an empty first child to - ## hold any parameters we might encounter inside the block. - if $key eq 'open' { - if $?BLOCK_OPEN { - @?BLOCK.unshift( $?BLOCK_OPEN ); - $?BLOCK_OPEN := 0; - } - else { - @?BLOCK.unshift( PAST::Block.new( PAST::Stmts.new(), :node($/))); - } - } - if $key eq 'close' { - my $past := @?BLOCK.shift(); - $past.push($.ast); - $past.hll($?RAKUDO_HLL); - make $past; - } -} - - -method block($/) { - my $past := $.ast; - unless $past { - set_block_type($past, 'Block'); - } - make $past; -} - - -method statementlist($/) { - my $past := PAST::Stmts.new( :node($/) ); - for $ { - $past.push( $_.ast ); - } - make $past; -} - - -method statement($/, $key) { - my $past; - if $key eq 'control' { - $past := $.ast; - } - elsif $key eq 'null' { - $past := PAST::Stmts.new(); - } - else { - my $sml; - $past := $.ast; - if $past.isa(PAST::Block) && !$past.blocktype() { - $past.blocktype('immediate'); - } - if $key eq 'mod_cond' { - my $body := $past; - $past := $.ast; - $past.push( $body ); - $past.push( PAST::Op.new( :name('list') ) ); - $sml := $[0]; - } - if $key eq 'mod_loop' { $sml := $; } - if $sml { - my $body := $past; - if $sml eq 'for' { - if !$body.isa(PAST::Block) { - $body := PAST::Block.new( PAST::Stmts.new(), $body ); - $body.blocktype('immediate'); - } - declare_implicit_function_vars( $body ); - } - $past := $sml.ast; - $past.push( $body ); - } - } - make $past; -} - - -method statement_control($/, $key) { - make $/{$key}.ast; -} - - -method if_statement($/) { - my $count := +$ - 1; - my $past := $[$count].ast; - declare_implicit_block_vars($past[1], 0); - ## add any 'else' clause - if $ { - my $else := $[0].ast; - $else.blocktype('immediate'); - declare_implicit_block_vars($else, 0); - $past.push( $else ); - } - ## build if/then/elsif structure - while $count != 0 { - $count--; - my $else := $past; - $past := $[$count].ast; - declare_implicit_block_vars($past[1], 0); - $past.push($else); - } - make $past; -} - -method unless_statement($/) { - my $past := $.ast; - $past.pasttype('unless'); - declare_implicit_block_vars($past[1], 0); - make $past; -} - -method while_statement($/) { - my $past := $.ast; - $past.pasttype(~$); - declare_implicit_block_vars($past[1], 0); - make $past; -} - -method repeat_statement($/) { - my $cond := $.ast; - my $block := $.ast; - $block.blocktype('immediate'); - declare_implicit_block_vars($block, 0); - # pasttype is 'repeat_while' or 'repeat_until' - my $pasttype := 'repeat_' ~ ~$; - make PAST::Op.new( $cond, $block, :pasttype($pasttype), :node($/) ); -} - -method given_statement($/) { - my $past := $.ast; - $past.push( $past.shift() ); # swap and - $past[0].blocktype('declaration'); - declare_implicit_function_vars($past[0]); - $past.pasttype('call'); - make $past; -} - -method when_statement($/) { - my $block := $.ast; - $block.blocktype('immediate'); - declare_implicit_block_vars($block, 0); - - # Push a handler onto the innermost block so that we can exit if we - # successfully match - when_handler_helper($block); - - # Invoke smartmatch of the expression. - my $match_past := process_smartmatch( - PAST::Var.new( :name('$_') ), - $.ast, - $ - ); - - # Use the smartmatch result as the condition. - my $past := PAST::Op.new( - $match_past, $block, - :pasttype('if'), - :node( $/ ) - ); - make $past; -} - -method default_statement($/) { - # Always executed if reached, so just produce the block. - my $block := $.ast; - $block.blocktype('immediate'); - declare_implicit_block_vars($block, 0); - - # Push a handler onto the innermost block so that we can exit if we - # successfully match - when_handler_helper($block); - - make $block; -} - -sub when_handler_helper($block) { - our @?BLOCK; - my $?BLOCK := @?BLOCK[0]; - # XXX TODO: This isn't quite the right way to check this... - unless $?BLOCK.handlers() { - my @handlers; - @handlers.push( - PAST::Control.new( - PAST::Op.new( - :pasttype('pirop'), - :pirop('return'), - PAST::Var.new( - :scope('keyed'), - PAST::Var.new( :name('exception'), :scope('register') ), - 'payload', - ), - ), - :handle_types('BREAK') - ) - ); - $?BLOCK.handlers(@handlers); - } - - # push a control exception throw onto the end of the block so we - # exit the innermost block in which $_ was set. - my $last := $block.pop(); - $block.push( - PAST::Op.new( - :pasttype('call'), - :name('break'), - $last - ) - ); - - # Push a handler onto the block to handle CONTINUE exceptions so we can - # skip throwing the BREAK exception - my @handlers; - if $block.handlers() { - @handlers := $block.handlers(); - } - @handlers.push( - PAST::Control.new( - PAST::Op.new( - :pasttype('pirop'), - :pirop('return'), - ), - :handle_types('CONTINUE') - ) - ); - $block.handlers(@handlers); -} - -method loop_statement($/) { - my $block := $.ast; - $block.blocktype('immediate'); - declare_implicit_block_vars($block, 0); - my $cond := $ ?? $[0].ast !! 1; - my $loop := PAST::Op.new( $cond, $block, :pasttype('while'), :node($/) ); - if $ { - $loop.push( $[0].ast ); - } - if $ { - $loop := PAST::Stmts.new( $[0].ast, $loop, :node($/) ); - } - make $loop; -} - -method for_statement($/) { - my $past := $.ast; - $past.pasttype('for'); - $past[0] := PAST::Op.new(:name('list'), $past[0]); - declare_implicit_function_vars($past[1]); - make $past; -} - -method pblock($/) { - my $block := $.ast; - ## Use bind_signature to fixup params and do typechecks. - if defined($block) { - $block[0].push(bind_signature_op()); - if $[0] eq '<->' { - block_signature($block).set_rw_by_default(); - } - } - ## If block has no statements, need to return an undef (so we don't - ## get a null PMC access) if it's a lambda (in the non-lambda case, - ## it may be a Hash composer). - if $ { - prevent_null_return($block); - } - make $block; -} - -method xblock($/) { - my $pblock := $.ast; - $pblock.blocktype('immediate'); - prevent_null_return($pblock); - my $past := PAST::Op.new( - $.ast, $pblock, - :pasttype('if'), - :node( $/ ) - ); - make $past; -} - -method use_statement($/) { - my $name := ~$; - my $past; - if $name ne 'v6' && $name ne 'lib' { - ## Create a loadinit node so the use module is loaded - ## when this module is loaded... - our @?BLOCK; - my $use_call := PAST::Op.new( - PAST::Val.new( :value($name) ), - :name('use'), - :pasttype('call'), - :node( $/ ) - ); - - ## Handle tags. - my $tags; - if $ { - $tags := $[0].ast; - if !($tags.isa(PAST::Op) && $tags.name() eq 'infix:,') { - $tags := PAST::Op.new( $tags ); - } - for @($tags) { - if $_.returns() ne 'Pair' { - $/.panic("Unknown import list expression in use"); - } - } - $tags.name('hash'); - $tags.pasttype('call'); - $tags.named('tags'); - $use_call.push($tags); - } - - ## Handle versioning - my $ver; - if $ { - $ver := PAST::Op.new( :pasttype('call'), :name('hash') ); - for $ { - my $pair := $_.ast; - $ver.push( $pair ); - if $pair[0].value() eq 'from' { - $/.add_type($name); - } - } - $ver.named('ver'); - $use_call.push($ver); - } - @?BLOCK[0].loadinit().push($use_call); - - ## ...and load it immediately to get its BEGIN semantics and - ## symbols for the current compilation. - ## XXX Need to handle tags here too, and creating needed lexical - ## slots. - our @?NS; - my %ver_hash; - for @($ver) { if $_ { %ver_hash{$_[0].value()} := $_[1].value() } } - if $tags { - my %tag_hash; - for @($tags) { %tag_hash{$_[0].value()} := 1 } - use($name, :import_to(@?NS ?? @?NS[0] !! ''), :ver(%ver_hash), :tags(%tag_hash)); - } else { - use($name, :import_to(@?NS ?? @?NS[0] !! ''), :ver(%ver_hash),); - } - } - $past := PAST::Stmts.new( :node($/) ); - make $past; -} - -method begin_statement($/) { - my $past := $.ast; - $past.blocktype('declaration'); - declare_implicit_routine_vars($past); # FIXME - my $sub := PAST::Compiler.compile( $past ); - $sub(); - # XXX - should emit BEGIN side-effects, and do a proper return() - make PAST::Block.new(); -} - -method start_statement($/) { - make make_start_block($.ast); -} - -method end_statement($/) { - my $past := $.ast; - $past.blocktype('declaration'); - declare_implicit_routine_vars($past); - $past.loadinit().push( - PAST::Op.new( - :pasttype('callmethod'), - :name('push'), - PAST::Var.new( - :namespace('Perl6'), - :name('@?END_BLOCKS'), - :scope('package') - ), - PAST::Var.new( - :name('block'), - :scope('register') - ) - ) - ); - make $past; -} - -method catch_statement($/) { - my $past := $.ast; - $past.blocktype('immediate'); - $past := PAST::Stmts.new( - PAST::Op.new( - :pasttype('bind'), - PAST::Var.new( :name('$_'), :scope('lexical') ), - PAST::Var.new( :name('exception'), :scope('register') ) - ), - PAST::Op.new( - :pasttype('bind'), - PAST::Var.new( :name('$!'), :scope('lexical') ), - PAST::Var.new( :name('exception'), :scope('register') ) - ), - $past - ); - our @?BLOCK; - my $?BLOCK := @?BLOCK[0]; - my $eh := PAST::Control.new( $past ); - my @handlers; - if $?BLOCK.handlers() { - @handlers := $?BLOCK.handlers(); - } - @handlers.unshift($eh); - $?BLOCK.handlers(@handlers); - make PAST::Stmts.new(); -} - -method control_statement($/) { - my $past := $.ast; - $past.blocktype('immediate'); - $past := PAST::Stmts.new( - PAST::Op.new( - :pasttype('bind'), - PAST::Var.new( :name('$_'), :scope('lexical') ), - PAST::Var.new( :name('exception'), :scope('register') ) - ), - PAST::Op.new( - :pasttype('bind'), - PAST::Var.new( :name('$!'), :scope('lexical') ), - PAST::Var.new( :name('exception'), :scope('register') ) - ), - $past - ); - our @?BLOCK; - my $?BLOCK := @?BLOCK[0]; - my $eh := PAST::Control.new( - $past, - :handle_types('CONTROL') - ); - my @handlers; - if $?BLOCK.handlers() { - @handlers := $?BLOCK.handlers(); - } - @handlers.unshift($eh); - $?BLOCK.handlers(@handlers); - make PAST::Stmts.new(); -} - - -method no_statement($/) { - if ~$ eq 'Main' { - our $?SUPPRESS_MAIN := 1; - } - make PAST::Stmts.new(); -} - - -method statement_mod_loop($/) { - my $expr := $.ast; - my $sym := ~$; - - if $sym eq 'given' { - my $assign := PAST::Op.new( - :name('infix::='), - :pasttype('bind'), - :node($/) - ); - $assign.push( - PAST::Var.new( :node($/), :name('$_'), :scope('lexical') ) - ); - $assign.push( $expr ); - - my $past := PAST::Stmts.new( $assign, :node($/) ); - make $past; - } - elsif $sym eq 'for' { - my $past := PAST::Op.new( - PAST::Op.new($expr, :name('list')), - :pasttype($sym), - :node( $/ ) - ); - make $past; - } - else { - make PAST::Op.new( - $expr, - :pasttype( $sym ), - :node( $/ ) - ); - } -} - - -method statement_mod_cond($/) { - my $sym := ~$; - my $expr := $.ast; - if $sym eq 'when' { - $expr := PAST::Op.new( - PAST::Var.new( :name('$_'), :scope('lexical') ), - $expr, - :name('infix:~~'), - :pasttype('call'), - :node($/) - ); - $sym := 'if'; - } - make PAST::Op.new( $expr, :pasttype($sym), :node($/) ); -} - - -method statement_prefix($/) { - my $past := $.ast; - my $sym := ~$; - - if $sym eq 'do' { - # fall through, just use the statement itself - } - ## after the code in the try block is executed, bind $! to Failure, - ## and set up the code to catch an exception, in case one is thrown - elsif $sym eq 'try' { - $past := PAST::Op.new( $past, :pasttype('try') ); - - ## Add a catch node to the try op that captures the - ## exception object into $!. - $past.push( PAST::Op.new( - :inline( " .get_results (%r)", - " $P0 = new ['Perl6Exception']", - " setattribute $P0, '$!exception', %r", - " store_lex '$!', $P0" - ) - ) - ); - - ## Add an 'else' node to the try op that clears $! if - ## no exception occurred. - my $elsepir := " %r = '!FAIL'()\n store_lex '$!', %r"; - $past.push( PAST::Op.new( :inline( $elsepir ) ) ); - } - elsif $sym eq 'gather' { - if !$past.isa(PAST::Block) { - $past := PAST::Block.new($past) - } - $past.blocktype('declaration'); - $past := PAST::Op.new( $past, :pasttype('call'), - :name('gather'), :node($/) ); - } - else { - $/.panic( $sym ~ ' not implemented'); - } - make $past; -} - - -method multi_declarator($/) { - my $sym := ~$; - my $past := $ ?? $.ast !! $.ast; - - if $past.isa(PAST::Block) { - # If we have a multi declarator, must have a named routine too. - if $sym ne "" && $past.name() eq "" { - $/.panic("'" ~ $ ~ "' can only be used on named routines"); - } - - # If we're declaring a multi or a proto, flag the sub as :multi, - # and transform the sub's container to a Perl6MultiSub. - if $sym eq 'multi' || $sym eq 'proto' { - transform_to_multi($past, @?BLOCK[0].symbol($past.name())); - our @?BLOCK; - my $existing := @?BLOCK[0].symbol($past.name()); - @?BLOCK[0].symbol($past.name(), :does_callable(1), - :is_proto($sym eq 'proto' || $existing), - :is_multi($sym eq 'multi')); - } - - # Protos also need the proto property setting on them, plus we note - # that we have one in scope. - if $ eq 'proto' { - $past.loadinit().push( - PAST::Op.new(:inline(' setprop block, "proto", %0'), 1) - ); - } - - # If it's just a routine, need to mark it as a sub and make sure we - # bind its signature. - if $ { - if (+@($past[1])) { - declare_implicit_routine_vars($past); - } - else { - $past[1].push( PAST::Op.new( :name('list') ) ); - } - set_block_type($past, 'Sub'); - $past[0].push(bind_signature_op()); - } - } - - make $past; -} - - -method enum_declarator($/, $key) { - my $values := $/{$key}.ast; - - my $name := ~$[0]; - if $name { - # It's a named enumeration. Ensure the type isn't already declared. - if $/.type_redeclaration() { - $/.panic("Re-declaration of type " ~ $name); - } - - # Get all of the names of the enum values we will introduce and register - # them as type names. - our @?BLOCK; - my $getvals_sub := PAST::Compiler.compile(PAST::Block.new( - :blocktype('declaration'), - :hll($?RAKUDO_HLL), - PAST::Op.new( - :pasttype('call'), - :name('!create_anon_enum'), - $values - ), - )); - my %values := $getvals_sub(); - for %values.keys() { - @?BLOCK[0].symbol($name ~ '::' ~ $_, :does_abstraction(1)); - @?BLOCK[0].symbol($_, :does_abstraction(1)); - } - - # Emit call to enum constructor in the block's loadinit. - @?BLOCK[0].loadinit().push(PAST::Op.new( - :pasttype('call'), - :name('!create_enum'), - $name, - $values - )); - - # Finally, since it's a decl, we don't have anything to emit at this - # point; just hand back empty statements block. - make PAST::Stmts.new(); - } - else { - # Emit runtime call anonymous enum constructor. - make PAST::Op.new( - :pasttype('call'), - :name('!create_anon_enum'), - $values - ); - } -} - - -method routine_declarator($/, $key) { - my $past; - if $key eq 'sub' { - $past := $.ast; - set_block_type($past, 'Sub'); - } - elsif $key eq 'method' { - $past := $.ast; - set_block_type($past, 'Method'); - if $past.name() eq 'BUILD' { - warn("BUILD declared as a method; you probably wanted to declare it as a submethod."); - } - } - elsif $key eq 'submethod' { - $past := $.ast; - set_block_type($past, 'Submethod'); - } - $past.node($/); - if (+@($past[1])) { - declare_implicit_routine_vars($past); - } - else { - $past[1].push( PAST::Op.new( :name('list') ) ); - } - ## Use bind_signature op to bind the signature, and also add a return - ## to make sure we type-check any implicitly return values for routines - ## with return type constraints. - $past[0].push(bind_signature_op()); - add_return_type_check_if_needed($past); - ## If we have a proto in scope of this name, then we need to make this a - ## multi. - if $past.name() ne "" { - my $sym := outer_symbol($past.name()); - if $sym && $sym && $sym { - transform_to_multi($past, 0); - } - } - make $past; -} - - -method routine_def($/) { - our $?BLOCK_OPEN; - unless $?BLOCK_OPEN { - $?BLOCK_OPEN := PAST::Block.new( PAST::Stmts.new(), :node($/) ); - } - my $block := $?BLOCK_OPEN; - $block.blocktype('declaration'); - if $ { - my $name := ~$[0]; - my $match := Perl6::Grammar::opname($name, :grammar('Perl6::Grammar') ); - if $match { $name := add_optoken($block, $match); } - our @?BLOCK; - my $existing := @?BLOCK[0].symbol($name); - if $existing && !$existing && !$existing { - warn("Redefinition of routine " ~ $name); - } - elsif !$existing || !$existing { - @?BLOCK[0].symbol( $name, :scope('package') ); - } - $block.name( $name ); - } - $block.control(return_handler_past()); - block_signature($block).set_default_parameter_type('Any'); - - if $ { - my $loadinit := $block.loadinit(); - my $blockreg := PAST::Var.new( :name('block'), :scope('register') ); - for @($) { - my $name := $_.ast.name; - if $name eq 'trait_mod:returns' || $name eq 'trait_mod:of' { - $block := 1; - } - } - emit_traits($, $loadinit, $blockreg); - } - make $block; -} - - -method method_def($/) { - my $block := $.ast; - $block.blocktype('method'); - - if $ { - my $name := ~$; - if $ eq '!' { $name := '!' ~ $name } - my $match := Perl6::Grammar::opname($name, :grammar('Perl6::Grammar') ); - if $match { $name := add_optoken($block, $match); } - $block.name( $name ); - } - - $block.control(return_handler_past()); - block_signature($block).set_default_parameter_type('Any'); - - # Add lexical 'self' and a slot for the candidate dispatcher list. - $block[0].unshift( - PAST::Var.new( :name('self'), :scope('lexical'), :isdecl(1), - :viviself( PAST::Var.new( :name('self'), :scope('register' ) ) ) - ) - ); - $block[0].unshift(PAST::Var.new( :name('__CANDIDATE_LIST__'), :scope('lexical'), :isdecl(1) )); - - # Add *%_ parameter if there's no other named slurpy and the package isn't hidden. - my $need_slurpy_hash := !$block.has_named_slurpy(); - if $need_slurpy_hash && !package_has_trait('hidden') { - $block[0].push(PAST::Var.new( :name('%_'), :scope('lexical'), :isdecl(1), :viviself('Perl6Hash') )); - block_signature($block).add_parameter( :var_name('%_'), :names(1), :slurpy(1) ); - } - - # Ensure there's an invocant in the signature, and that it's in the - # positional arguments. - block_signature($block).add_invocant(); - - # Handle traits. - if $ { - my $loadinit := $block.loadinit(); - my $blockreg := PAST::Var.new( :name('block'), :scope('register') ); - for @($) { - my $name := $_.ast.name; - if $name eq 'trait_verb:returns' || $name eq 'trait_verb:of' { - $block := 1; - } - } - emit_traits($, $loadinit, $blockreg); - } - - # If it's a metaclass method, make it anonymous and then push a call to - # !add_metaclass_method onto the current class definition. - if $ eq '^' { - our $?METACLASS; - our @?BLOCK; - $block.pirflags(~$block.pirflags() ~ ' :anon '); - my $add_meta := PAST::Op.new( - :pasttype('call'), - :name('!add_metaclass_method'), - $?METACLASS, - $block.name, - PAST::Op.new( :inline(' .const "Sub" %r = "' ~ $block.subid ~ '"') ) - ); - if @?BLOCK[0] eq 'role' || @?BLOCK[0] { - @?BLOCK[0][0].push($add_meta); - } - else { - @?BLOCK[0].loadinit().push($add_meta); - } - } - - make $block; -} - - -method trait($/) { - my $past; - if $ { - $past := $.ast; - } - elsif $ { - $/.panic('traits specified as colon pairs not yet understood'); - } - make $past; -} - - -method trait_mod($/) { - my $sym := ~$; - - # Traits are mostly handled by a call to a trait_mod routine. We build - # a call to this; the declarand will get unshifted onto it later. - my $trait := PAST::Op.new( - :pasttype('call'), - :name('trait_mod:' ~ $sym) - ); - - # Now handle the bits specific to each type of trait. - if $sym eq 'is' { - if $ { - my $arg := $[0].ast; - $arg.name('!capture'); - $trait.push($arg); - } - if $/.is_type(~$) { - # It's a type - look it up and send it in as a positional, before - # the parameter. - my @name := Perl6::Compiler.parse_name(~$); - $trait.unshift(PAST::Var.new( - :scope('package'), - :name(@name.pop()), - :namespace(@name) - )); - } - else { - # Not a type name, so construct a named parameter with this name; it - # is a named param so it has to go on the end. - $trait.push(PAST::Var.new( - :name('True'), - :namespace('Bool'), - :scope('package'), - :named(~$) - )); - } - $trait := ~$; - } - elsif $sym eq 'does' { - $trait.push( $.ast ); - } - elsif $sym eq 'handles' { - $trait.push( $.ast ); - } - elsif $sym eq 'will' { - $trait.push( $.ast ); - if $/.is_type(~$) { - # It's a type - look it up and send it in as a positional, before - # the parameter. - $trait.unshift(PAST::Var.new( - :scope('package'), - :name(~$) - )); - } - else { - # Not a type name, so construct a named parameter with this name; it - # is a named param so it has to go on the end. - $trait.push(PAST::Val.new( - :value(PAST::Var.new( :name('True'), :namespace('Bool'), :scope('package') )), - :named(~$) - )); - } - } - elsif $sym eq 'hides' { - my @name := Perl6::Compiler.parse_name(~$); - $trait.push(PAST::Var.new( - :name(@name.pop), - :namespace(@name), - :scope('package') - )); - } - else { - $trait.push( $.ast ); - } - - make $trait; -} - - -method signature($/, $key) { - our @?BLOCK; - if $key eq 'open' { - our $?BLOCK_OPEN; - my $sigpast := PAST::Op.new( :pasttype('stmts'), :node($/) ); - my $block; - if $?BLOCK_OPEN { - $block := $?BLOCK_OPEN; - $?BLOCK_OPEN := 0; - $block.unshift( $sigpast); - } - else { - $block := PAST::Block.new( $sigpast, :blocktype('declaration') ); - } - $block := 1; - @?BLOCK.unshift($block); - } - else { - my $block := @?BLOCK.shift(); - my $sigpast := $block[0]; - my $loadinit := $block.loadinit(); - my $signature := block_signature($block); - - ## loop through parameters of signature - my $arity := $ ?? +@($) !! 0; - $block.arity($arity); - my $i := 0; - my $multi_inv_suppress := 0; - while $i < $arity { - my $var := $[$i].ast; - my $name := $var.name(); - - ## Emit code for type bindings. - if $var { - $sigpast.push( $var ); - } - - ## Compute read type. - my $readtype := trait_readtype( $var ); - if $readtype eq 'CONFLICT' { - $[$i].panic( - "Can use only one of readonly, rw, and copy on " - ~ $name ~ " parameter" - ); - } - - ## if it's an invocant, flag it as such provided it is the first - ## parameter; otherwise, it's an error. - my $invocant := 0; - if $[$i][0] eq ':' { - if $i == 0 { - $invocant := 1; - $sigpast.push(PAST::Var.new( - :name($var.name()), - :scope('lexical'), - :isdecl(1), - :viviself(PAST::Var.new( :name('self'), :scope('register') )) - )); - } - else { - $/.panic("Can only use : separator to denote invocant after first parameter."); - } - } - - ## otherwise, if it has a name, create a lexical with a matching name that - ## we will put the parameter in. Exception: when it's an attributive. - elsif $var.name() && !$var { - $var.scope('lexical'); - $var.isdecl(1); - unless $var.viviself() { - $var.viviself($var); - } - $sigpast.push($var); - } - - ## if there's a sub-signature, need lexicals it declares too. - if defined($var) { - for @($var.lexicals()) { - if $_.isa(PAST::Var) && $_.scope() eq 'lexical' { - $sigpast.push($_); - $block.symbol( $_.name(), :scope('lexical') ); - } - } - } - - ## add entry to signature object - $signature.add_parameter( - :var_name( $var.name() ), - :twigil( $var ), - :optional( $var ?? 1 !! 0 ), - :slurpy( $var.slurpy() ), - :names( $var.slurpy() ?? $var.named() !! - ($var.named() eq "" ?? list() !! list($var.named())) ), - :read_type( $readtype ), - :invocant( $invocant ), - :multi_invocant( $multi_inv_suppress ?? 0 !! 1 ), - :nom_type( $var ), - :cons_type( $var ), - :type_captures( $var ?? list($var.name()) !! list() ), - :default( $var ?? - PAST::Block.new( :blocktype('declaration'), $var ) !! 0 ), - :sub_signature( defined($var) ?? $var !! undef() ) - ); - - ## handle end of multi-invocant sequence - if $[$i][0] eq ';;' { $multi_inv_suppress := 1; } - - $i++; - } - - ## attach leicals we made to the signature, for sub-signature handling. - $signature.lexicals($sigpast); - - ## handle return type written with --> T - if $ { - set_return_type($block, $); - } - - ## restore block stack and return signature ast - our $?BLOCK_OPEN; - $?BLOCK_OPEN := $block; - make $signature; - } -} - - -method type_constraint($/) { - my $past; - if $ { - $past := $.ast; - } - elsif $ { - $past := make_anon_subtype($.ast); - } - else { - my $value := $.ast; - $past := PAST::Op.new( - :name('infix:,'), - PAST::Op.new( - :pasttype('callmethod'), - :name('WHAT'), - $value - ), - make_anon_subtype($value) - ); - } - make $past; -} - - -method post_constraint($/) { - my $past := make_anon_subtype($.ast); - make $past; -} - - -method parameter($/) { - my $sigil := $ ?? $ !! $; - my $quant := $; - - ## if it was type a type capture and nothing else, need to make a PAST::Var - my $var; - if $ { - $var := $.ast; - } - elsif $ { - $var := $.ast; - } - else { - unless $ == 1 { - $/.panic("Invalid signature; cannot have two consecutive parameter separators."); - } - our @?BLOCK; - my $name := ~$[0]; - $var := PAST::Var.new( :scope('parameter') ); - $var.name($var.unique('::TYPE_CAPTURE')); - @?BLOCK[0].symbol( $var.name(), :scope('lexical') ); - } - - ## handle slurpy and optional flags - if $quant eq '*' { - $var.slurpy( $sigil eq '@' || $sigil eq '%' ); - if $var.slurpy() { $var.named( $sigil eq '%' ); } - } - elsif $ { # named - if $quant ne '!' { # required (optional is default) - $var := 1; - } - } - elsif $quant eq '?' { # positional optional - $var := 1; - } - - ## handle any default value - if $ { - if $quant eq '!' { - $/.panic("Can't put a default on a required parameter"); - } - if $quant eq '*' { - $/.panic("Can't put a default on a slurpy parameter"); - } - $var := $[0].ast; - $var := 1; - } - - ## keep track of any type constraints - if $ { - if $ != 1 { - $/.panic("Multiple prefix constraints not yet supported"); - } - for @($) { - my $type_past := $_.ast; - if $type_past.isa(PAST::Var) && $type_past.scope() eq 'lexical' { - our @?BLOCK; - # Lexical type constraint. - if $type_past.isdecl() { - # If it's a declaration, we need to initialize it. - $type_past.viviself(container_itype('$')); - $var := $type_past; - @?BLOCK[0].symbol( $type_past.name(), :scope('lexical') ); - } - else { - # we need to thunk it - since it's a thunk, needs to be a - # constraint type really. - my $thunk := PAST::Op.new( - :name('ACCEPTS'), :pasttype('callmethod'), - $type_past, - PAST::Var.new( :name('$_'), :scope('parameter') ) - ); - $thunk := PAST::Block.new($thunk, :blocktype('declaration')); - @?BLOCK[0].push($thunk); - $type_past := PAST::Val.new( :value($thunk) ); - $var := PAST::Op.new( :name('all'), :pasttype('call'), $type_past ); - } - } - elsif $type_past.isa(PAST::Op) && $type_past.name() eq 'infix:,' { - # It's a literal value - implies both a nominal type and constraint type. - $var := $type_past[0]; - $var := PAST::Op.new( :name('all'), :pasttype('call'), $type_past[1] ); - } - else { - $var := $type_past; - } - } - } - if $ { - unless $var { - $var := PAST::Op.new( :name('all'), :pasttype('call') ); - } - for @($) { - $var.push($_.ast); - } - } - - # Attatch list of traits. - $var := $; - - make $var; -} - - -method named_param($/) { - my $var := $.ast; - if $ { - $var.named(~$); - } - else { - $var.named(~$[0]); - } - make $var; -} - -method param_var($/) { - if $ { - my $sigil := substr(~$/, 0, 1); - my $name := $sigil eq '[' ?? '@' !! '$'; - my $var := PAST::Var.new( - :name($name), - :scope('parameter'), - :node($/) - ); - $var := container_itype($sigil); - $var := $.ast; - make $var; - } - else { - my $sigil := ~$; - my $twigil := ~$[0]; - if $sigil eq '&' { $sigil := ''; } - my $name := $sigil ~ $twigil ~ ~$[0]; - if $twigil eq '.' { - $name := $sigil ~ '!' ~ $[0]; - } - elsif $twigil && $twigil ne '!' { - $/.panic('Invalid twigil used in signature parameter.'); - } - my $var := PAST::Var.new( - :name($name), - :scope('parameter'), - :node($/) - ); - $var := $twigil; - $var := container_itype( $ ); - # Declare symbol as lexical in current (signature) block. - # This is needed in case any post_constraints try to reference - # this new param_var. - our @?BLOCK; - @?BLOCK[0].symbol( $name, :scope('lexical') ); - make $var; - } -} - - -method expect_term($/, $key) { - my $past := $/{$key}.ast; - - if $ { - for $ { - my $term := $past; - $past := $_.ast; - if $past.name() eq 'infix:,' { $past.name(''); } - - if $past.isa(PAST::Op) - && $past.pasttype() eq 'callmethod' - && !$past.name() { - # indirect call, invocant needs to be second arg - my $meth := $past[0]; - $past[0] := $term; - $past.unshift($meth); - } - elsif $past { - $past.unshift(deref_invocant($term)); - } - else { - $past.unshift($term); - } - } - } - make $past; -} - - -method post($/, $key) { - my $past := $/{$key}.ast; - - if $ { - if $past.isa(PAST::Op) && $past.pasttype() eq 'call' { - $past.unshift($past.name()); - $past.name('!dispatch_dispatcher_parallel'); - } - elsif $past.isa(PAST::Op) && $past.pasttype() eq 'callmethod' { - $past.unshift($past.name()); - $past.name('!dispatch_method_parallel'); - $past.pasttype('call'); - } - else { - $/.panic("Unimplemented or invalid use of parallel dispatch"); - } - } - - make $past; -} - - -method dotty($/, $key) { - my $past; - - if $key eq '.*' { - $past := $.ast; - if $/[0] eq '.?' || $/[0] eq '.+' || $/[0] eq '.*' || $/[0] eq '.^' || $/[0] eq '.=' { - my $name := $past.name(); - if $name && !$name.isa(PAST::Node) { - $name := PAST::Val.new( :value($name) ); - } - if $name { - $past.unshift($name); - $past.unshift(PAST::Op.new(:inline(' null %r'))); - } - else { - my $cands := $past.shift(); - $past.unshift(''); - $past.unshift(PAST::Op.new( - :pasttype('callmethod'), - :name('list'), - $cands - )); - } - $past.name('!' ~ $/[0]); - } - else { - $/.panic($/[0] ~ ' method calls not yet implemented'); - } - } - else { - if $key eq '.' { - # Just a normal method call. - $past := $.ast; - } - elsif $key eq '!' { - # Private method call. Need to put ! on the start of the name - # (unless it was call to a code object, in which case we don't do - # anything more). - $past := $.ast; - my $methodop := $; - if $methodop { - $past.name('!' ~ $past.name()); - } - elsif $methodop { - $past.name( - PAST::Op.new( - :pasttype('call'), - :name('infix:~'), - '!', - $past.name() - ) - ); - } - } - elsif $key eq 'VAR' { - $past := PAST::Op.new( - :pasttype('call'), - :name('!VAR'), - :node($/) - ); - } - - # We actually need to send dispatches for named method calls (other than .*) - # through the.dispatcher. - if $past { - $past.name('!dispatch_method_indirect'); - $past.pasttype('call'); - } - } - - $past := $past; - make $past; -} - - -method dottyop($/, $key) { - make $/{$key}.ast; -} - - -method methodop($/, $key) { - my $past; - - if $key eq 'null' { - $past := PAST::Op.new(); - } - else { - $past := build_call( $/{$key}.ast ); - } - $past.pasttype('callmethod'); - $past.node($/); - - if $ { - my @ns := Perl6::Compiler.parse_name(~$); - my $short_name := ~@ns.pop(); - - if @ns { - $past.name(''); - $past.unshift(PAST::Op.new( - :inline(' %r = find_method %0, "' ~ $short_name ~ '"'), - PAST::Var.new( - :scope('package'), - :name(@ns.pop), - :namespace(@ns) - ))); - $past := 1; - } - else { - $past.name(~$); - } - } - elsif $ { - $past.unshift( $.ast ); - $past := 1; - } - else { - $past.name( $.ast ); - } - - make $past; -} - -method postcircumfix($/, $key) { - my $past; - if $key eq '[ ]' { - $past := PAST::Op.new( :name('postcircumfix:[ ]'), :node($/) ); - if $ { - $past.push( $.ast ); - } - } - elsif $key eq '( )' { - $past := build_call( $.ast ); - $past.node($/); - } - elsif $key eq '{ }' { - $past := build_call( $.ast ); - $past.node($/); - $past.name('postcircumfix:{ }'); - } - elsif $key eq '< >' { - $past := build_call( $.ast ); - $past.node($/); - $past.name('postcircumfix:{ }'); - } - else { - $/.panic("postcircumfix " ~ $key ~ " not yet implemented"); - } - make $past; -} - - -method noun($/, $key) { - my $past; - if $key eq 'self' { - $past := PAST::Var.new( - :name('self'), - :scope('lexical'), - :node($/) - ); - } - elsif $key eq 'dotty' { - # Call on $_. - $past := $/{$key}.ast; - $past.unshift(deref_invocant(PAST::Var.new( - :name('$_'), - :scope('lexical'), - :viviself('Failure'), - :node($/) - ))); - } - else { - $past := $/{$key}.ast; - } - make $past; -} - - -method package_declarator($/, $key) { - our @?PKGDECL; - our @?NS; - my $sym := ~$; - my $past; - if $key eq 'open' { - our $?BLOCK_OPEN; - $?BLOCK_OPEN := PAST::Block.new( PAST::Stmts.new(), :node($/) ); - $?BLOCK_OPEN := $sym; - @?PKGDECL.unshift( $sym ); - } - elsif $key eq 'package_def' { - make $.ast; - @?PKGDECL.shift(); - } - elsif $key eq 'does' { - our @?BLOCK; - our $?METACLASS; - my $block := @?BLOCK[0]; - my $pkgdecl := $block; - unless $pkgdecl eq 'class' || $pkgdecl eq 'role' || $pkgdecl eq 'grammar' { - $/.panic("Cannot use does package declarator outside of class, role, or grammar"); - } - my $pushee := $pkgdecl eq 'role' ?? $block[0] !! $block.loadinit(); - $pushee.push(PAST::Op.new( - :name('trait_mod:does'), - $?METACLASS, - $.ast - )); - make PAST::Stmts.new() - } -} - - -method package_def($/, $key) { - our @?PKGDECL; - my $?PKGDECL := @?PKGDECL[0]; - our @?NS; - - if $key eq 'panic' { - $/.panic("Unable to parse " ~ $?PKGDECL ~ " definition"); - } - - # At block opening, unshift module name (fully qualified) onto @?NS; otherwise, - # shift it off. - if $key eq 'open' { - my $add := ~$[0] eq '::' ?? '' !! - (~$[0] ~ ~$[0]); - my $fqname := +@?NS ?? @?NS[0] ~ '::' ~ $add !! $add; - @?NS.unshift($fqname); - - # Also attach traits to the node. - our $?BLOCK_OPEN; - $?BLOCK_OPEN := $; - if $add eq '' { - $?BLOCK_OPEN := 1; - } - - return 0; - } - else { - @?NS.shift(); - } - - my $block := $/{$key}.ast; - declare_implicit_routine_vars($block); - - my $modulename; - my $is_anon := 0; - if $ && ~$[0] ne '::' { - $modulename := ~$[0] ~ ~$[0]; - } - else { - $modulename := $block.unique('!ANON'); - $is_anon := 1; - } - if +@?NS > 0 { - $modulename := @?NS[0] ~ '::' ~ $modulename; - } - - # See note at top of file for %?CLASSMAP. - if %?CLASSMAP{$modulename} { $modulename := %?CLASSMAP{$modulename}; } - - if $?PKGDECL eq 'role' { - # Parametric roles need to have their bodies evaluated per type- - # parmeterization, and are "invoked" by 'does'. We make them - # multis, and ensure they have a signature. XXX Need to put - # $?CLASS as first item in signature always too. - $block.blocktype('declaration'); - - # Also need to put this (possibly parameterized) role into the - # set of possible roles. - $block.loadinit().push( - PAST::Op.new( :name('!ADDTOROLE'), :pasttype('call'), - PAST::Var.new( :name('block'), :scope('register') ) - ) - ); - - # And if there's no signature, make sure we set one up and add [] to - # the namespace name. - if substr($modulename, -1, 1) ne ']' { - $modulename := $modulename ~ '[]'; - block_signature($block); - } - $block[0].push(bind_signature_op()); - } - elsif $key eq 'block' { - # A normal block runs inline. - $block.blocktype('immediate'); - } - elsif $key eq 'statement_block' { - # file-level blocks have their contents as the compunit mainline - if !$ { - $/.panic("Compilation unit cannot be anonymous"); - } - $block.blocktype('immediate'); - } - - if ($modulename) { - $block.namespace( Perl6::Compiler.parse_name($modulename) ); - } - - # Create a node at the beginning of the block's initializer - # for package initializations if it's a role, or loadinit if - # it's anything else. - my $init := PAST::Stmts.new(); - if $?PKGDECL eq 'role' || $is_anon { - $block[0].unshift( $init ); - } - else { - $block.loadinit().unshift( $init ); - } - - # Set is also flag. - $block := has_compiler_trait_with_val($, 'trait_mod:is', 'also'); - - # Emit traits; make sure rw always is marked as compiler handled and hidden is - # always emitted even though we also have somewhat handled it in the compiler. - has_compiler_trait_with_val($, 'trait_mod:is', 'rw'); - my $hidden := has_compiler_trait_with_val($, 'trait_mod:is', 'hidden'); - if $hidden { $hidden := 0 } - emit_traits($, $init, $?METACLASS); - - # If it's not an "is also", have a name and aren't a role (since they can - # have many declarations) we need to check it's not a duplicate. - our $?METACLASS; - if !$block && !$is_anon && $?PKGDECL ne 'role' { - if $/.type_redeclaration() { - $/.panic("Re-declaration of type " ~ ~$[0]); - } - } - - ## If it is an "is also", check that the type did already exist. - if $block && !$/.type_redeclaration() { - $/.panic("Cannot use 'is also' on non-existent class " ~ ~$[0]); - } - - # At the beginning, create the "class/module/grammar/role/etc" - # metaclass handle on which we do the other operations. - $init.unshift( - PAST::Op.new( :pasttype('bind'), - PAST::Var.new(:name('metaclass'), :scope('register'), :isdecl(1) ), - PAST::Op.new(:name('!meta_create'), - $?PKGDECL, $modulename, ($block ?? 1 !! 0) - ) - ) - ); - - # ...and at the end of the block's initializer (after any other - # items added by the block), we finalize the composition. - if $?PKGDECL eq 'role' { - # For a role, we now need to produce a copy of the role - # and clones of the methods (having captured the current - # lexical context). - $block[0].push( - PAST::Op.new( - :inline(' .tailcall "!create_parametric_role"(%0)'), - $?METACLASS - ) - ); - } - elsif $is_anon && ($?PKGDECL eq 'class' || $?PKGDECL eq 'grammar') { - # We need to keep the proto around and return it at the end of - # initialization for anonymous classes. - $block[0].push(PAST::Op.new( - :pasttype('bind'), - PAST::Var.new(:name('proto_store'), :scope('register'), :isdecl(1)), - PAST::Op.new( :name('!meta_compose'), $?METACLASS) - )); - $block.push(PAST::Var.new(:name('proto_store'), :scope('register'))); - $block.blocktype('immediate'); - } - elsif !$block { - $block.loadinit().push( PAST::Op.new( :name('!meta_compose'), $?METACLASS) ); - } - else { - $block.loadinit().push( PAST::Op.new( :name('!setup_invoke_vtable'), $?METACLASS) ); - } - - make $block; -} - - -method scope_declarator($/) { - our @?BLOCK; - my $block := @?BLOCK[0]; - my $sym := ~$; - my $past := $.ast; - my $scope := 'lexical'; - if $sym eq 'our' { $scope := 'package'; } - elsif $sym eq 'has' { $scope := 'attribute'; } - elsif $sym eq 'state' { $scope := 'state'; } - - # Private methods get a leading !. - if $scope eq 'lexical' && $past.isa(PAST::Block) - && $past.blocktype() eq 'method' { - $past.name( '!' ~ $past.name()); - } - - # If we have a single variable, we temporarily pack it into - # a PAST::Op node (like a signature of one variable) and - # let the PAST::Op code below handle it. It then gets - # unpacked at the end. - if $past.isa(PAST::Var) { - $past := PAST::Op.new( $past ); - } - - if $past.isa(PAST::Op) { - my $i := 0; - for @($past) { - if $_.isa(PAST::Var) && !$_ { - my $var := $_; - - # This is a variable declaration, so we set the scope in - # the block's symbol table as well as the variable itself. - $block.symbol( $var.name(), :scope($scope) ); - $var.scope($scope); - $var.isdecl(1); - if $scope eq 'package' { $var.lvalue(1); } - my $init_value := $var.viviself(); - my $type; - if $var { - $type := $var; - } - - # If the var has a '.' twigil, we need to create an - # accessor method for it in the block (class/grammar/role) - my $readtype; - if $var eq '.' { - my $method := PAST::Block.new( :blocktype('method') ); - if $var eq '&' { - $method.name( substr($var.name(), 1) ); - } else { - $method.name( substr($var.name(), 2) ); - } - my $value := PAST::Var.new( :name($var.name()) ); - my $default_readtype := package_has_trait('rw') ?? 'rw' !! 'readonly'; - $readtype := trait_readtype( $var ) || $default_readtype; - if $readtype eq 'CONFLICT' { - $.panic( - "Can use only one of readonly, rw, and copy on " - ~ $var.name() ~ " parameter" - ); - } - elsif $readtype ne 'rw' { - $value := PAST::Op.new( :pirop('new PsP'), - 'ObjectRef', $value); - $value := PAST::Op.new( :pirop('setprop'), - $value, 'readonly', 1); - } - $method.push( $value ); - $block[0].push($method); - } - - if $scope eq 'attribute' { - # If no twigil, we need a twigiled entry of - # the attribute in the block's symbol table. - if $var eq '' { - my $sigil := substr($var.name(), 0, 1); - my $name := substr($var.name(), 1); - $block.symbol( $sigil ~ '!' ~ $name, :scope($scope)); - } - my $pkgdecl := $block; - unless $pkgdecl eq 'class' || $pkgdecl eq 'role' - || $pkgdecl eq 'grammar' { - $/.panic("Attempt to define attribute " ~ $var.name() ~ - " outside of class, role, or grammar"); - } - # Attribute declaration. Add code to the beginning - # of the block (really class/grammar/role) to - # create the attribute. - our $?METACLASS; - my $has := PAST::Op.new( :name('!meta_attribute'), - $?METACLASS, $var.name(), $var ); - if $type { - my $type_copy := $type.clone(); - $type_copy.named('type'); - $has.push($type_copy); - } - if $init_value { - $init_value := make_attr_init_closure($init_value); - $init_value.named('init_value'); - $has.push($init_value); - } - if $var eq '.' { - $has.push(PAST::Val.new( :value(1), :named('accessor') )); - } - if $readtype eq 'rw' { - $has.push(PAST::Val.new( :value(1), :named('rw') )); - } - if $var || $type { - # If we have a handles, then we pass that specially. - my $handles := has_compiler_trait($var, 'trait_mod:handles'); - if $handles { - $handles[0].named('handles'); - $has.push($handles[0]); - } - - # We'll make a block for calling other handles, which'll be - # thunked. - my $trait_stmts := PAST::Stmts.new(); - my $declarand := PAST::Op.new( - :pasttype('callmethod'), :name('new'), - PAST::Var.new( :name('AttributeDeclarand'), :scope('package'), :namespace(list()) ), - PAST::Var.new( :name('$_'), :scope('lexical'), :named('container') ), - PAST::Val.new( :value($var.name()), :named('name') ), - PAST::Var.new( :name('$how'), :scope('lexical'), :named('how') ) - ); - emit_traits($var, $trait_stmts, $declarand); - if $type { - $trait_stmts.push(PAST::Op.new( - :pasttype('call'), - :name('trait_mod:of'), - $declarand, - $type - )); - } - if +@($trait_stmts) > 0 { - my $trait_block := PAST::Block.new( - :blocktype('declaration'), - PAST::Var.new( :name('$_'), :scope('parameter') ), - PAST::Var.new( :name('$how'), :scope('parameter') ), - $trait_stmts - ); - $trait_block.named('traits'); - $has.push($trait_block); - } - } - if $pkgdecl eq 'role' || $block { - $block[0].push( $has ); - } - else { - $block.loadinit().push( $has ); - } - } - else { - # $scope eq 'package' | 'lexical' | 'state' - my $viviself := PAST::Op.new( :pirop('new PsP'), $var ); - if $init_value { $viviself.push( $init_value ); } - my $init_reg_name := $viviself.unique('initvar_'); - my $init_reg := PAST::Var.new( :name($init_reg_name), :scope('register') ); - $var.viviself(PAST::Stmts.new( - PAST::Op.new( - :pasttype('bind'), - PAST::Var.new( :name($init_reg_name), :scope('register'), :isdecl(1) ), - $viviself - ) - )); - - # Trait and type handling. - $init_reg.named('container'); - my $declarand := PAST::Op.new( - :pasttype('callmethod'), :name('new'), - PAST::Var.new( :name('ContainerDeclarand'), :scope('package'), :namespace(list()) ), - $init_reg, - PAST::Val.new( :value($var.name()), :named('name') ) - ); - emit_traits($var, $var.viviself(), $declarand); - if $type { - if $var ne '$' && $var ne '@' && $var ne '%' && $var ne '' { - $/.panic("Cannot handle typed variables with sigil " ~ $var); - } - $var.viviself.push(PAST::Op.new( - :pasttype('call'), - :name('trait_mod:of'), - $declarand, - $type - )); - } - $var.viviself.push(PAST::Op.new( :inline(' %r = %0'), $init_reg )); - if $sym eq 'constant' { - # Do init in viviself, and then make sure we mark it readonly after - # that point. - $var := PAST::Op.new( - :pasttype('call'), - :name('infix:='), - $var - ); - $var := PAST::Op.new( :pirop('setprop'), $var, 'readonly', 1); - $var := $var[0]; - $var := 'constant'; - } - } - $past[$i] := $var; - } - $i++; - } - if $scope eq 'attribute' { - $past := $scope; - $past.pasttype('null'); - } - elsif +@($past) == 1 { $past := $past[0]; } - else { $past.name('infix:,'); $past.pasttype('call'); } - if $scope eq 'state' { - $past := $scope; - block_has_state($block); - } - } - - # If we have a lexical sub, need to do some work. If it's single dispatch - # then we just need to grab and bind it to a lexical. If it's a multi, we - # need to clone the outer multi if we didn't already and push this candidate - # onto it. To avoid doing this clone every time we invoke the block (would - # be costly) we use state variables to persist it. - if $past.isa(PAST::Block) && $past.blocktype() ne 'method' { - if $scope eq 'lexical' { - # Block needs to become anonymous. - my $name := $past.name(); - $past.name($past.unique('block_')); - - if $past { - my $sym_info := $block.symbol($name); - my $result := PAST::Stmts.new(:node($/)); - - if $sym_info ne 'lexical' { - # First multi of this name. Create state var for storing candidate - # list. - my $outer := outer_symbol($name, 1); - $result.push(PAST::Var.new( - :name($name), - :scope('state'), - :isdecl(1), - :viviself(PAST::Op.new( - :pasttype('call'), - :name('!clone_multi_for_lexical'), - $outer eq 'lexical' ?? - PAST::Op.new( :inline(" %r = find_lex_skip_current '" ~ $name ~ "'") ) !! - PAST::Var.new( :name($name), :scope('package') ) - )) - )); - block_has_state($block); - $block.symbol($name, :scope('lexical'), :does_callable(1), :is_multi(1)); - } - elsif !$sym_info { - $/.panic('only sub conflicts with multi'); - } - - # Emit START block for adding this candidate. - $result.push(make_start_block(PAST::Block.new( - PAST::Stmts.new(), - PAST::Op.new( - :pasttype('callmethod'), - :name('push'), - PAST::Var.new( :name($name), :scope('lexical') ), - $past - ) - ))); - $past := $result; - } - else { - $past := PAST::Var.new( - :name($name), - :scope('lexical'), - :isdecl(1), - :viviself($past) - ); - $block.symbol($name, :scope('lexical'), :does_callable(1)); - } - } - elsif $scope ne 'package' { - $/.panic('Can not use ' ~ $scope ~ ' scope with a sub.'); - } - } - - make $past; -} - - -method scoped($/) { - my $past; - if $ { - $past := $.ast; - } - elsif $ { - $past := $.ast; - if $past.isa(PAST::Var) { - if +@($) == 1 { - $past := $[0].ast; - } - else { - $/.panic("Multiple prefix constraints are not yet supported"); - } - if $past eq '$' { - # Scalars auto-vivify to the proto of their type. - $past.viviself( $[0].ast.clone() ); - } - } - elsif $past.isa(PAST::Block) && $ { - set_return_type($past, $); - add_return_type_check_if_needed($past); - } - } - make $past; -} - - -method declarator($/) { - my $past; - if $ { - $past := $.ast; - } - elsif $ { - $past := $.ast; - } - elsif $ { - # We actually want a list of the thingies that the signature declares, - # rather than the signature object itself. - $past := $.ast.get_declarations(); - - # XXX This should really be able to go away shortly... - our $?BLOCK_OPEN; - $?BLOCK_OPEN := 0; - } - elsif $ { - $past := $.ast; - } - make $past; -} - - -method variable_declarator($/) { - our @?BLOCK; - my $var := $.ast; - - ## The $ subrule might've saved a PAST::Var node for - ## us (e.g., $.x), if so, use it instead. - - if $var { $var := $var; } - my $name := $var.name(); - my $symbol := @?BLOCK[0].symbol( $name ); - if $symbol eq 'lexical' { - warn("Redeclaration of variable " ~ $name); - $var := 1; - $var.isdecl(0); - } - else { - $var.isdecl(1); - $var := container_itype($); - $var := $; - } - - make $var; -} - - -method constant_declarator($/) { - our @?BLOCK; - my $past := PAST::Var.new( - :name(~$), - :scope('lexical'), - ); - $past := container_itype('Perl6Scalar'); - $/.add_type(~$); - @?BLOCK[0].symbol(~$, :scope('lexical')); - make $past; -} - - -method variable($/, $key) { - my $var; - our @?BLOCK; - my $?BLOCK := @?BLOCK[0]; - if $key eq 'desigilname' { - my $sigil := ~$; - if $sigil eq '&' { $sigil := ''; } - my $twigil := ~$[0]; - my @ns := Perl6::Compiler.parse_name( $ ); - my $name := ~@ns.pop(); - my $varname := $sigil ~ $twigil ~ $name; - - # If no twigil, but varname is 'attribute' in outer scope, - # it's really a private attribute and implies a '!' twigil - if !$twigil { - my $sym := outer_symbol($varname); - if $sym && $sym eq 'attribute' { - $twigil := '!'; - $varname := $sigil ~ $twigil ~ $name; - }; - } - - # If twigil is ^ or :, it's a placeholder var. Create the - # parameter for the block if one doesn't already exist. - if $twigil eq '^' || $twigil eq ':' { - if $?BLOCK { - $/.panic("Cannot use placeholder var in block with signature."); - } - $varname := $sigil ~ $name; - unless $?BLOCK.symbol($varname) { - $?BLOCK.symbol( $varname, :scope('lexical') ); - $?BLOCK.arity( +$?BLOCK.arity() + 1 ); - my $param := PAST::Var.new(:name($varname), :scope('lexical'), :isdecl(1), :viviself(container_itype($sigil))); - my $blockinit := $?BLOCK[0]; - $blockinit.push($param); - my $signature := block_signature($?BLOCK); - if $twigil eq ':' { - $signature.add_parameter( :var_name($varname), :names( list($name) ) ); - } - else { - $signature.add_placeholder_parameter( :var_name($varname) ); - } - } - ## use twigil-less form afterwards - $twigil := ''; - } - - $var := PAST::Var.new( :name($varname), :node($/) ); - $var := ~$; - if $twigil { $var := $twigil; } - - # Variables with '*' twigils are contextual. Normally - # this is handled by a call to !find_contextual, but - # we also create a PAST::Var in case it's a variable - # declaration. - if $twigil eq '*' { - my $vardecl := $var; - $var := PAST::Op.new( $varname, - :name('!find_contextual'), - :lvalue(0) ); - $vardecl.name($varname); - $vardecl.namespace(@ns); - $vardecl.scope('package'); - $var := $vardecl; - $twigil := ''; - } - - if @ns { - $twigil := ''; - $varname := $sigil ~ $name; - $var.name($varname); - $var.namespace(@ns); - $var.scope('package'); - $var.viviself( container_itype($sigil) ); - } - - ## @_ and %_ add a slurpy param to the block - if $varname eq '@_' || $varname eq '%_' { - unless $?BLOCK.symbol($varname) { - $?BLOCK.symbol( $varname, :scope('lexical') ); - my $param := PAST::Var.new( :name($varname), :scope('lexical'), - :isdecl(1), :viviself(container_itype($sigil)) ); - my $signature := block_signature($?BLOCK); - $signature.add_parameter( :var_name($varname), :slurpy(1), :names($sigil eq '%' ?? 1 !! list()) ); - $?BLOCK[0].unshift($param); - } - } - - # Until PCT has 'name' scope, we handle lexical/package lookup here. - if $ eq '&' { - my $sym := outer_symbol($varname); - $var.scope( ($sym && $sym) || 'package'); - if $var.scope() eq 'package' { - $var.viviself(PAST::Op.new( :pasttype('call'), :name('undef') )); - } - } - - # The ! twigil always implies attribute scope and needs self. - if $twigil eq '!' { - $var.scope('attribute'); - $var.unshift( PAST::Var.new( :name('self'), :scope('lexical') ) ); - } - - } - elsif $key eq 'methcall' { - my $name := ~$; - my $sigil := ~$; - if $sigil eq '&' { $sigil := ''; } - - # Normally $.foo is a method call, so we return a PAST::Op node for it. - $var := $ ?? $[0].ast !! PAST::Op.new(); - $var.pasttype('callmethod'); - $var.name($name); - $var.unshift( PAST::Var.new( :name('self'), :scope('lexical') ) ); - $var.node($/); - - # Sometimes $.foo is an attribute declaration, so we create a - # PAST::Var node in $var where it can be retrieved - # by . (Eventually we'll be able to use - # $*IN_DECL to decide which to return.) - my $vardecl := PAST::Var.new( - :name($sigil ~ '!' ~ $name), - :scope('attribute'), - :node($/), - PAST::Var.new( :name('self'), :scope('lexical') ) ); - $vardecl := ~$; - $vardecl := '.'; - $var := $vardecl; - } - elsif $key eq 'special_variable' { - $var := $.ast; - } - elsif $key eq '$0' { - $var := PAST::Var.new( - :scope('keyed_int'), - :node($/), - :viviself('Failure'), - PAST::Var.new( :scope('lexical'), :name('$/') ), - +$ ); - } - elsif $key eq '$<>' { - $var := $.ast; - $var.unshift( PAST::Var.new( :scope('lexical'), :name('$/'), - :viviself('Failure'), :node($/) ) - ); - } - elsif $key eq 'subnoun' { - my $varname := ~$; - my $match := - Perl6::Grammar::opname($varname, :grammar('Perl6::Grammar')); - if $match { $varname := ~$match ~ ':' ~ ~$match[0]; } - $var := PAST::Var.new( :name($varname), :node($/) ); - $var := ''; - my $sym := outer_symbol($varname); - $var.scope( ($sym && $sym) || 'package'); - if $var.scope() eq 'package' { - $var.viviself(PAST::Op.new( :pasttype('call'), :name('undef') )); - } - } - - make $var; -} - - -method special_variable($/) { - make PAST::Var.new( :node($/), :name(~$/), :scope('lexical') ); -} - - -method circumfix($/, $key) { - my $past; - if $key eq '( )' { - $past := $ - ?? $.ast - !! PAST::Op.new(:pirop('new Ps'), 'Nil'); - } - if $key eq '[ ]' { - $past := PAST::Op.new(:name('circumfix:[ ]'), :node($/) ); - if $ { $past.push( $.ast ); } - } - elsif $key eq '{ }' { - # If it is completely empty or consists of a single list, the first - # element of which is either a hash or a pair, it's a hash constructor. - $past := $.ast; - my $is_hash := 0; - if +@($past) == 2 && +@($past[0]) == 0 { - if +@($past[1]) == 0 { - # Empty block, so a hash. - $is_hash := 1; - } - elsif +@($past[1]) == 1 && $past[1][0].isa(PAST::Op) { - if $past[1][0].name() eq 'infix:=>' { - # Block with just one pair in it, so a hash. - $is_hash := 1; - } - elsif $past[1][0].name() eq 'infix:,' { - # List, but first elements must be... - if $past[1][0][0].isa(PAST::Op) && - $past[1][0][0].name() eq 'infix:=>' { - # ...a Pair - $is_hash := 1; - } - elsif $past[1][0][0].isa(PAST::Var) && - substr($past[1][0][0].name(), 0, 1) eq '%' { - # ...or a hash. - $is_hash := 1 - } - } - } - elsif +@($past[1]) == 1 && $past[1][0].isa(PAST::Var) { - if substr($past[1][0].name(), 0, 1) eq '%' { - $is_hash := 1; - } - } - } - if $is_hash { - my @children := @($past[1]); - $past := PAST::Op.new( - :pasttype('call'), - :name('circumfix:{ }'), - :node($/) - ); - for @children { - $past.push($_); - } - } - else { - declare_implicit_function_vars($past); - } - } - elsif $key eq '$( )' { - my $method := contextualizer_name($/, $); - my $call_on := $.ast; - if $call_on.name() eq 'infix:,' && +@($call_on) == 0 { - $call_on := PAST::Var.new( - :name('$/'), - :scope('lexical') - ); - } - $past := PAST::Op.new( - :pasttype('callmethod'), - :name($method), - :node($/), - $call_on - ); - } - elsif $key eq 'quote' { - $past := $.ast; - } - make $past; -} - - -method value($/, $key) { - make $/{$key}.ast; -} - - -method typename($/) { - # Extract shortname part of identifier, if there is one. - my $ns := Perl6::Compiler.parse_name($); - my $shortname := $ns.pop(); - - my $past := PAST::Var.new( :name($shortname), :namespace($ns), :node($/) ); - - my $scope := ''; - our @?BLOCK; - if +$ns == 0 && @?BLOCK { - for @?BLOCK { - if defined($_) && !$scope { - my $sym := $_.symbol($shortname); - if defined($sym) && $sym { $scope := $sym; } - } - } - } - - $past.scope($scope || 'package'); - make $past; -} - - -method fulltypename($/) { - my $past := $.ast; - if substr( ~$, 0, 2) eq '::' { - $past.isdecl(1); - $past.scope('lexical'); - } - if $ { - my $call := $[0].ast; - $call.unshift($past); - $past := $call; - } - if $ { - $past := PAST::Op.new( - :pasttype('call'), - :name('postcircumfix:[ ]'), - $past, - $[0].ast - ); - } - make $past; -} - - -method number($/, $key) { - make $/{$key}.ast; -} - - -## for a variety of reasons, this is easier in PIR than NQP for now. -## NQP doesn't have assign yet, and Str is lighter-weight than Str. -method integer($/) { - my $str; - PIR q< $P0 = find_lex '$/' >; - PIR q< $S0 = $P0 >; - PIR q< $P1 = new ['Str'] >; - PIR q< assign $P1, $S0 >; - PIR q< store_lex '$str', $P1 >; - make PAST::Val.new( - :value( +$str ), - :returns('Int'), - :node( $/ ) - ); -} - - -method dec_number($/) { - my $str; - PIR q< $P0 = find_lex '$/' >; - PIR q< $S0 = $P0 >; - PIR q< $P1 = new ['Str'] >; - PIR q< assign $P1, $S0 >; - PIR q< store_lex '$str', $P1 >; - make PAST::Val.new( - :value( +$str ), - :returns('Num'), - :node( $/ ) - ); -} - -method radint($/, $key) { - make $/{$key}.ast; -} - -method rad_number($/) { - my $radix := ~$; - my $intpart := ~$; - my $fracpart := ~$; - my $base; - my $exp; - if defined( $[0] ) { $base := ~$[0]; } - if defined( $[0] ) { $exp := ~$[0]; } - if ~$ { - my $radcalc := $.ast; - $radcalc.name('radcalc'); - $radcalc.pasttype('call'); - $radcalc.unshift( PAST::Val.new( :value( $radix ), :node( $/ ) ) ); - make $radcalc; - } - else{ - my $return_type := 'Int'; - if $fracpart { $return_type := 'Num'; } - make PAST::Val.new( - :value( radcalc( $radix, $intpart, $fracpart, ~$base, ~$exp ) ), - :returns($return_type), - :node( $/ ) - ); - } -} - - -method quote($/) { - my $past := $.ast; - if $ eq 'x' { - $past := PAST::Op.new( :name('!qx'), :pasttype('call'), $past ); - } - make $past; -} - -method quote_expression($/, $key) { - my $past; - if $key eq 'quote_concat' { - if +$ == 1 { - $past := $[0].ast; - } - else { - $past := PAST::Op.new( - :name('list'), - :pasttype('call'), - :node( $/ ) - ); - for $ { - $past.push( $_.ast ); - } - } - } - elsif $key eq 'quote_regex' { - $past := PAST::Block.new( - $, - :compiler('PGE::Perl6Regex'), - :blocktype('declaration'), - :node( $/ ) - ); - set_block_type($past, 'Regex'); - } - elsif $key eq 'quote_p5regex' { - $past := PAST::Block.new( - $, - :compiler('PGE::P5Regex'), - :blocktype('declaration'), - :node( $/ ) - ); - set_block_type($past, 'Regex'); - } - elsif $key eq 'quote_pir' { - $past := PAST::Op.new( :inline( $ ), :node($/) ); - } - make $past; -} - - -method quote_concat($/) { - my $quote_term := $; - my $terms := +$quote_term; - my $count := 1; - my $past := $quote_term[0].ast; - while ($count != $terms) { - $past := PAST::Op.new( - $past, - $quote_term[$count].ast, - :pirop('concat'), - :pasttype('pirop') - ); - $count := $count + 1; - } - make $past; -} - - -method quote_term($/, $key) { - my $past; - if ($key eq 'literal') { - $past := PAST::Val.new( - :value( ~$.ast ), - :returns('Str'), :node($/) - ); - } - elsif ($key eq 'variable') { - $past := PAST::Op.new( $.ast, :name('prefix:~'), :pasttype('call') ); - } - elsif ($key eq 'circumfix') { - $past := $.ast; - if $past.isa(PAST::Block) { - $past.blocktype('immediate'); - } - $past := PAST::Op.new( $past, :name('prefix:~'), :pasttype('call') ); - } - make $past; -} - - -method term($/, $key) { - my $past; - - my @ns; - my $short_name; - if $ { - @ns := Perl6::Compiler.parse_name(~$); - $short_name := @ns.pop(); - } - - if $key eq '*' { - # Whatever. - $past := make_whatever($/); - } - elsif $key eq '**' { - $/.panic('** (HyperWhatever) is not yet implemented'); - } - elsif $key eq 'noarg' { - if @ns { - $past := PAST::Op.new( - PAST::Var.new( - :name($short_name), - :namespace(@ns), - :scope('package'), - :viviself('Failure'), - ), - :pasttype('call') - ); - } - else { - if $short_name eq 'print' || $short_name eq 'say' { - $/.panic($short_name ~ ' requires an argument'); - } - $past := PAST::Op.new( :name( $short_name ), :pasttype('call') ); - } - } - elsif $key eq 'args' { - $past := $.ast; - if @ns { - $past.unshift(PAST::Var.new( - :name($short_name), - :namespace(@ns), - :scope('package'), - :viviself('Failure'), - )); - } - else { - if +@($past) == 0 && ($short_name eq 'print' || $short_name eq 'say') { - $/.panic($short_name ~ ' requires an argument'); - } - $past.name( $short_name ); - } - } - elsif $key eq 'func args' { - $past := build_call( $.ast ); - if @ns { - $past.unshift(PAST::Var.new( - :name($short_name), - :namespace(@ns), - :scope('package'), - :viviself('Failure'), - )); - } - else { - $past.name( $short_name ); - } - } - elsif $key eq 'VAR' { - $past := PAST::Op.new( - :name('!VAR'), - :pasttype('call'), - $.ast - ); - } - elsif $key eq 'sigil' { - my $method := contextualizer_name($/, $); - - $past := PAST::Op.new( - :pasttype('callmethod'), - :name($method), - :node($/), - $.ast - ); - } - else { $past := $/{$key}.ast; } - $past.node($/); - make $past; -} - - -method term_START($/) { - make make_start_block($.ast); -} - - -method args($/, $key) { - my $past := build_call( $key eq 'func args' - ?? $.ast - !! $.ast - ); - make $past; -} - - -method semilist($/) { - my $past := $ - ?? $[0].ast - !! PAST::Op.new( :node($/), :name('infix:,') ); - make $past; -} - - -method arglist($/) { - my $past := $ - ?? $.ast - !! PAST::Op.new( :node($/), :name('infix:,') ); - make $past; -} - - -method EXPR($/, $key) { - my $type := ~$; - - if $key eq 'end' { - make $.ast; - } - elsif +@($/) == 2 && $/[0].ast eq 'state' && $ { - # State variables - only want to actually do an assignment if - # there is no value. - my $lhs := $/[0].ast; - my $rhs := $/[1].ast; - make PAST::Op.new( - :pasttype('unless'), - :node($/), - PAST::Op.new( - :pasttype('call'), - :name('!state_var_inited'), - $lhs.isa(PAST::Var) ?? $lhs.name() !! $lhs[0].name() - ), - PAST::Op.new( - :pasttype('call'), - :name('infix:='), - :lvalue(1), - $lhs, - $rhs - ) - ); - } - elsif ~$type eq 'infix:=' { - my $lhs := $/[0].ast; - my $rhs := $/[1].ast; - my $past; - - if $lhs eq 'attribute' { - # Need to transform RHS into an anonymous method. - $rhs := make_attr_init_closure($rhs); - $rhs.named('init_value'); - our $?METACLASS; - $past := PAST::Op.new( :name('!meta_attribute'), - $?METACLASS, $lhs[0].name(), $rhs - ); - our @?BLOCK; - if @?BLOCK[0] eq 'role' || @?BLOCK[0] { - @?BLOCK[0][0].push($past); - } - else { - @?BLOCK[0].loadinit().push($past); - } - $past := PAST::Stmts.new(); - } - elsif $lhs eq 'constant' { - $lhs.push($rhs); - $past := $lhs; - } - else { - # Just a normal assignment. - $past := PAST::Op.new( - :pasttype('call'), - :name('infix:='), - :lvalue(1), - $lhs, - $rhs - ); - } - - make $past; - } - elsif ~$type eq 'infix:.=' { - my $invocant := $/[0].ast; - my $call := $/[1].ast; - - # Check that we have a sub call. - if !$call.isa(PAST::Op) || $call.pasttype() ne 'call' { - $/[0].panic('.= must have a call on the right hand side'); - } - - # Change call node to a callmethod. - $call.pasttype('callmethod'); - - # We only want to evaluate invocant once; stash it in a register. - $call.unshift(PAST::Op.new( - :pasttype('bind'), - PAST::Var.new( - :name('detemp'), - :scope('register'), - :isdecl(1) - ), - $invocant - )); - - # Do call, then assignment to target container. - my $past := PAST::Op.new( - :inline(" %r = 'infix:='(%1, %0)"), - :node($/), - $call, - PAST::Var.new( - :name('detemp'), - :scope('register') - ) - ); - - make $past; - } - elsif ~$type eq 'infix:does' || ~$type eq 'infix:but' { - my $past := PAST::Op.new( - $/[0].ast, - :pasttype('call'), - :name(~$type), - :node($/) - ); - my $rhs := $/[1].ast; - if $rhs.isa(PAST::Op) && $rhs.pasttype() eq 'call' { - # Make sure we only have one initialization value. - if +@($rhs) > 2 { - $/[0].panic("Role initialization can only supply a value for one attribute"); - } - # Push role name and argument onto infix:does or infix:but. - $past.push($rhs[0]); - $past.push($rhs[1]); - } - else { - $past.push($rhs); - } - make $past; - } - elsif ~$type eq 'infix:~~' { - # Smart-match. We need to detect and specially dispatch a few special forms; the - # rest fall through to a call to .ACCEPTS. - my $lhs := $/[0].ast; - my $rhs := $/[1].ast; - make process_smartmatch($lhs, $rhs, $/[1]); - } - elsif ~$type eq 'prefix:|' { - # Need to make it flatten the argument. - my $past := $/[0].ast; - $past.flat(1); - if $past eq '%' { - $past.named(1); - } - make $past; - } - elsif ~$type eq 'infix://=' || ~$type eq 'infix:||=' || ~$type eq 'infix:&&=' { - my $lhs := $/[0].ast; - my $rhs := $/[1].ast; - make PAST::Stmts.new( - PAST::Op.new( :pasttype('bind'), PAST::Var.new( :name('$P0'), :scope('register') ), $lhs ), - PAST::Op.new( - :pasttype('call'), - :name('infix:='), - PAST::Var.new( :name('$P0'), :scope('register') ), - PAST::Op.new(PAST::Var.new( :name('$P0'), :scope('register') ), $rhs, :pasttype( - ~$type eq 'infix://=' ?? 'def_or' !! - (~$type eq 'infix:||=' ?? 'unless' !! - 'if')) - ) - ) - ); - } - else { - my $past := PAST::Op.new( - :node($/), - :name($type), - :opattr($) - ); - if $ { $past.name(~$); } - for @($/) { - unless +$_.from() == +$_.to() { $past.push( $_.ast ) }; - } - - make $past; - } -} - - -method regex_declarator($/) { - my $sym := ~$; - my $past := $.ast; - if $sym eq 'token' - { $past.compiler_args( :grammar(''), :ratchet(1) ); } - elsif $sym eq 'rule' - { $past.compiler_args( :grammar(''), :s(1), :ratchet(1) ); } - else - { $past.compiler_args( :grammar('') ); } - make $past; -} - -method regex_def($/) { - my $past := $.ast; - $past.name( ~$[0] ); - make $past; -} - -method regex_block($/) { - make $.ast; -} - - -method type_declarator($/) { - # Make sure it's not a re-declaration. - if $/.type_redeclaration() { - $/.panic("Re-declaration of type " ~ ~$); - } - - # We need a block containing the constraint condition if there is one; if - # not, we just pass along the PAST for Whatever, which smart-matches anything. - my $past := make_anon_subtype($ ?? $[0].ast !! make_whatever($/)); - - # Create subset type. - my @name := Perl6::Compiler.parse_name($); - $past.blocktype('declaration'); - $past.loadinit().push(PAST::Op.new( - :node($/), - :pasttype('bind'), - PAST::Var.new( - :name(@name.pop()), - :namespace(@name), - :scope('package') - ), - PAST::Op.new( - :pasttype('call'), - :name('!CREATE_SUBSET_TYPE'), - $ ?? - $[0].ast - !! - PAST::Var.new( - :name('Any'), - :scope('package') - ), - PAST::Var.new( :name('block'), :scope('register') ) - ) - )); - - make $past; -} - - -method fatarrow($/) { - my $past := PAST::Op.new( - :node($/), - :pasttype('call'), - :name('infix:=>'), - :returns('Pair'), - PAST::Val.new( :value(~$) ), - $.ast - ); - make $past; -} - - -method colonpair($/, $key) { - my $pair_key; - my $pair_val; - - if $key eq 'false' { - $pair_key := PAST::Val.new( :value(~$) ); - $pair_val := PAST::Val.new( :value(0), :returns('Int') ); - } - elsif $key eq 'value' { - $pair_key := PAST::Val.new( :value(~$) ); - if $ { - $pair_val := $[0].ast; - if $pair_val.name() ne 'infix:,' || +@($pair_val) == 1 { - $pair_val := $pair_val[0]; - } - } - else { - $pair_val := PAST::Val.new( :value(1), :returns('Int') ); - } - } - elsif $key eq 'varname' { - if $ { - $pair_key := PAST::Val.new( :value( ~$ ) ); - $pair_val := PAST::Var.new( - :name( ~$ ~ ~$[0] ~ $ ) - ); - } - else { - $/.panic('complex varname colonpair case not yet implemented'); - } - } - - my $past := PAST::Op.new( - :node($/), - :pasttype('call'), - :name('infix:=>'), - :returns('Pair'), - $pair_key, - $pair_val - ); - make $past; -} - - -method capterm($/) { - # We will create the capture object, passing the things supplied. - my $past := build_call( $.ast ); - $past.name('prefix:\\'); - make $past; -} - - -method capture($/) { - make $.ast; -} - - -method sigterm($/) { - # Create high-level signature object. (First call extracts Signature - # object from Match object, second asks it to generate PAST that - # will produce a high-level Perl 6 Signature object. - my $past := $.ast.ast(1); - make $past; -} - - -# search through outer blocks for a symbol table entry -sub outer_symbol($name, $skip_first?) { - our @?BLOCK; - my $symbol; - for @?BLOCK { - if !$skip_first || !($_ =:= @?BLOCK[0]) { - $symbol := $_.symbol($name); - if $symbol { return $symbol; } - } - } - return $symbol; -} - - -# Used by all calling code to process arguments into the correct form. -sub build_call($args) { - if !$args.isa(PAST::Op) || $args.name() ne 'infix:,' { - $args := PAST::Op.new( :node($args), $args); - } - my $i := 0; - my $elems := +@($args); - while $i < $elems { - my $x := $args[$i]; - if $x.returns() eq 'Pair' { - $x[1].named($x[0]); - $args[$i] := $x[1]; - } - $i++; - } - $args.pasttype('call'); - $args.name(''); - $args; -} - - -sub declare_implicit_routine_vars($block) { - for ('$_', '$/', '$!') { - unless $block.symbol($_) { - $block[0].push( PAST::Var.new( - :name($_), :scope('lexical'), :isdecl(1), - :viviself(PAST::Op.new( - :inline(' %r = root_new ["parrot";"Perl6Scalar"]') ) ) - ) ); - $block.symbol($_, :scope('lexical') ); - } - } -} - - -sub declare_implicit_block_vars($block, $tparam) { - $block[0].push( PAST::Op.new( - :inline(' .local pmc outerlex', - ' getinterp $P0', - ' set outerlex, $P0["outer";"lexpad";1]'))); - for ('$_', '$/', '$!') { - unless $block.symbol($_) { - my $lex := PAST::Op.new(:inline(' set %r, outerlex["'~$_~'"]')); - my $var := PAST::Var.new( :name($_), :scope('lexical'), - :isdecl(1), :viviself($lex) ); - $block[0].push( $var ); - $block.symbol($_, :scope('lexical') ); - if $tparam && $_ eq '$_' { - my $signature := block_signature($block); - $signature.add_parameter( :var_name('$_'), :optional(1), :read_type('rw') ); - $block[0].push(bind_signature_op()); - } - } - } -} - -sub declare_implicit_function_vars($block) { - declare_implicit_block_vars($block, !defined($block.arity())); -} - -sub contextualizer_name($/, $sigil) { - ## Contextualizing is calling .item, .list, .hash, etc. - ## on the expression in the brackets - my $method; - if $sigil eq '$' { $method := 'item'; } - elsif $sigil eq '@' { $method := 'list'; } - elsif $sigil eq '%' { $method := 'hash'; } - else { - $/.panic("Use of contextualizer " ~ $sigil ~ " not implemented."); - } - $method -} - - -sub container_itype($sigil) { - if $sigil eq '@' { return 'Perl6Array' } - elsif $sigil eq '%' { return 'Perl6Hash' } - else { return 'Perl6Scalar' } -} - - -sub trait_readtype($traits) { - my $readtype; - if has_compiler_trait_with_val($traits, 'trait_mod:is', 'readonly') { - $readtype := 'readonly'; - } - if has_compiler_trait_with_val($traits, 'trait_mod:is', 'rw') { - $readtype := $readtype ?? 'CONFLICT' !! 'rw'; - } - if has_compiler_trait_with_val($traits, 'trait_mod:is', 'copy') { - $readtype := $readtype ?? 'CONFLICT' !! 'copy'; - } - $readtype; -} - - -# Produces a handles method. -# Generates a setter/getter method for an attribute in a class or role. -sub make_accessor($/, $method_name, $attr_name, $rw, $scope) { - my $getset; - if $rw { - $getset := PAST::Var.new( :name($attr_name), :scope($scope) ); - } - else { - $getset := PAST::Op.new( - :inline( - ' %r = root_new ["parrot";"ObjectRef"], %0', - ' $P0 = get_hll_global [ "Bool" ], "True"', - ' setprop %r, "readonly", $P0' - ), - PAST::Var.new( :name($attr_name), :scope($scope) ) - ); - } - my $accessor := PAST::Block.new( - PAST::Stmts.new($getset), - :blocktype('declaration'), - :name($method_name), - :pirflags(':method'), - :node( $/ ) - ); - $accessor -} - - -# Creates an anonymous subset type. -sub make_anon_subtype($past) { - # We need a block containing the constraint condition and do smart-match - # it against $_. - if !$past.isa(PAST::Block) || $past.compiler() eq 'PGE::Perl6Regex' { - $past := PAST::Block.new( - PAST::Stmts.new(), - PAST::Stmts.new( - PAST::Op.new( - :name('infix:~~'), - :pasttype('call'), - PAST::Var.new( :name('$_'), :scope('lexical') ), - $past - ) - ) - ); - declare_implicit_function_vars($past); - set_block_type($past, 'Block'); - } - - $past; -} - - -# Returns the code to set $?PACKAGE to the current package. -sub set_package_magical() { - return PAST::Var.new( - :name('$?PACKAGE'), - :scope('lexical'), - :isdecl(1), - :viviself(PAST::Op.new(:pirop('get_namespace P'))) - ); -} - - -sub block_signature($block) { - unless defined($block) { - $block := Perl6::Compiler::Signature.new(); - $block.loadinit().push($block); - $block.loadinit().push( - PAST::Op.new( :inline(' setprop block, "$!signature", signature') ) - ); - $block[0].push(PAST::Var.new( :name('call_sig'), :scope('parameter'), :call_sig(1) )); - } - return $block; -} - - -sub bind_signature_op() { - PAST::Op.new( - :pirop('bind_signature vP'), - PAST::Var.new( :name('call_sig'), :scope('lexical') ) - ) -} - -# Adds to the loadinit to set the type of a block. -sub set_block_type($block, $type) { - # If the block already has a type node, edit it. - if $block { - $block[1] := $type; - } - else { - my $set_type := PAST::Op.new( - :pasttype('call'), - :name('!fixup_routine_type'), - PAST::Var.new( :name('block'), :scope('register') ), - $type - ); - $block := $set_type; - $block.loadinit().unshift($set_type); - } -} - - -# Makes a routine into a multi, if it isn't already one. -sub transform_to_multi($past, $already_p6multi) { - unless $past { - my $pirflags := ~$past.pirflags(); - $past.pirflags( $pirflags ~ ' :multi()' ); - unless ($already_p6multi) { - $past.loadinit().unshift( - PAST::Op.new( :name('!TOPERL6MULTISUB'), :pasttype('call'), - PAST::Var.new( :name('block'), :scope('register') ) - ) - ); - } - $past := 1; - } -} - - -# Hanldes syntactic forms of smart-matching (factored out here since it's used -# by infix:~~ and the when statement. -sub process_smartmatch($lhs, $rhs, $rhs_pt) { - if $rhs_pt { - # method truth - $rhs[0] := deref_invocant($lhs); - if $rhs_pt { - # array/hash slice truth - $rhs := PAST::Op.new( :pasttype('call'), :name('all'), $rhs); - } - return PAST::Op.new( :pasttype('call'), :name('prefix:?'), $rhs); - } - else { - return PAST::Op.new( :pasttype('call'), :name('infix:~~'), $lhs, $rhs); - } -} - - -# Gives a block an undef to return if it has no statements, to prevent Null -# PMCs being handed back. -sub prevent_null_return($block) { - if +@($block[1]) == 0 { - $block[1].push(PAST::Op.new( - :pasttype('call'), - :name('undef') - )); - } -} - - -# This makes a START block (factored out since used as a term and a statement). -sub make_start_block($past) { - # Set up block. - $past.blocktype('immediate'); - declare_implicit_routine_vars($past); - - # Mark block as needing to load state. - our @?BLOCK; - block_has_state(@?BLOCK[0]); - - # We now need to emit code to run the block only once, and store the - # result. We'll just piggy-back off state vars. - return PAST::Var.new( - :scope('state'), - :name($past.unique('start_block_')), - :viviself($past), - :isdecl(1) - ); -} - -# This takes a block and ensures we emit code to load any associated state -# (START blocks, state variables) at block entry. -sub block_has_state($block) { - unless $block { - $block[0].push(PAST::Op.new( - :pasttype('call'), - :name('!state_var_init') - )); - $block := 1; - } -} - -# Manufactures PAST to handle check of return type. -sub return_handler_past() { - PAST::Stmts.new( - PAST::Op.new( :inline(' exception = getattribute exception, "payload"') ), - PAST::Op.new( - :pasttype('if'), - PAST::Op.new( - :pasttype('callmethod'), - :name('ACCEPTS'), - PAST::Op.new( :inline(" %r = interpinfo .INTERPINFO_CURRENT_SUB", - " %r = getprop '$!real_self', %r", - " %r = %r.'of'()", - " $P0 = %r") ), - PAST::Var.new( :name('exception'), :scope('register') ) - ), - PAST::Op.new( - :inline(' .return (%0)'), - PAST::Var.new( :name('exception'), :scope('register') ) - ), - PAST::Op.new( - :pasttype('if'), - PAST::Op.new( :inline(" $I0 = isa exception, 'Failure'", - " %r = box $I0") ), - PAST::Op.new( - :inline(' .return (%0)'), - PAST::Var.new( :name('exception'), :scope('register') ) - ), - PAST::Op.new( - :pasttype('call'), - :name('die'), - PAST::Op.new( - :pasttype('call'), - :name('!make_type_fail_message'), - 'Return value', - PAST::Var.new( :name('exception'), :scope('register') ), - PAST::Var.new( :name('$P0'), :scope('register') ) - ) - ) - ) - ) - ) -} - - -sub add_to_signature_from_past_var($signature, $var) { - $signature.add_parameter( - :var_name( $var.name() ), - :optional( $var.viviself() ?? 1 !! 0 ), - :slurpy( $var.slurpy() ), - :names( $var.named() eq "" ?? list() !! list($var.named()) ) - ); -} - - -sub add_optoken($block, $match) { - my $category := ~$match; - my $name := $category ~ ':' ~ ~$match[0]; - if $category ne 'trait_mod' && $name ne 'postcircumfix:( )' { - my $equiv := 'infix:+'; - if $category eq 'prefix' { $equiv := 'prefix:+' } - elsif $category eq 'postfix' { $equiv := 'postfix:++' } - elsif $category eq 'circumfix' || $category eq 'postcircumfix' { $equiv := 'term:' } - my $past := PAST::Op.new( :name('newtok'), :pasttype('callmethod'), - PAST::Op.new( - :inline(" %r = get_hll_global ['Perl6';'Grammar'], '$optable'") - ), - $name, - PAST::Val.new( :value($equiv), :named('equiv') ), - ); - my $sub := PAST::Compiler.compile( - PAST::Block.new( $past, :hll($?RAKUDO_HLL), :blocktype('declaration') ) - ); - $sub(); - $block.loadinit().push($past); - if $category eq 'infix' { - # For infix operators, we generate the meta-operators too. - $past := PAST::Op.new( - :name('!generate_meta_ops'), :pasttype('call'), - $name, $equiv - ); - $sub := PAST::Compiler.compile( - PAST::Block.new( $past, :hll($?RAKUDO_HLL), :blocktype('declaration') ) - ); - $sub(); - $block.loadinit().push($past); - } - } - $name; -} - - -sub make_attr_init_closure($init_value) { - # Need to not just build the closure, but new_closure it; otherwise, we - # run into trouble if our initialization value involves a parameter from - # a parametric role. - PAST::Op.new( - :inline('%r = newclosure %0'), - PAST::Block.new( - :blocktype('method'), - PAST::Stmts.new( - PAST::Var.new( :name('$_'), :scope('parameter') ), - PAST::Op.new( :pasttype('bind'), - PAST::Var.new( :name('self'), :scope('lexical'), :isdecl(1) ), - PAST::Var.new( :name('self'), :scope('register') ) - ) - ), - PAST::Stmts.new( $init_value ) - ) - ); -} - - -sub deref_invocant($inv) { - PAST::Op.new( :inline(' %r = descalarref %0'), $inv ) -} - - -sub set_return_type($block, $type_parse_tree) { - if +$type_parse_tree > 1 { - $type_parse_tree[0].panic("Multiple prefix constraints not yet supported"); - } - if $block { - $type_parse_tree[0].panic("Can not apply two sets of return types to one routine"); - } - $block.loadinit().push(PAST::Op.new( - :pasttype('call'), - :name('trait_mod:of'), - PAST::Var.new( :name('block'), :scope('register') ), - $type_parse_tree[0].ast - )); - $block := 1; -} - - -sub add_return_type_check_if_needed($block) { - if $block { - $block[1] := PAST::Op.new( - :pasttype('call'), - :name('return'), - $block[1] - ); - } -} - - -sub package_has_trait($name) { - our $?BLOCK_OPEN; - our @?BLOCK; - my $block := $?BLOCK_OPEN || @?BLOCK[0]; - return has_compiler_trait_with_val($block, 'trait_mod:is', $name); -} - - -sub make_whatever($/) { - PAST::Op.new( - :pasttype('callmethod'), - :name('new'), - :node($/), - :lvalue(1), - PAST::Var.new( - :name('Whatever'), - :namespace(list()), - :scope('package'), - :node($/) - ) - ) -} - - -# This routine checks if the given list of traits contains one of the given -# name. If so, it marks it as compiler handled so no multi call will be -# emitted when we emit the traits. If there is such a trait, it returns it's -# AST. -sub has_compiler_trait($trait_list, $name) { - if $trait_list { - for @($trait_list) { - my $ast := $_.ast; - if $ast.name eq $name { - $ast := 1; - return $ast; - } - } - } - return 0; -} - - -# This routine checks if the given list of traits contains one of the given -# names and also that it carries the given value as a named parameter. If so, -# it marks it as compiler handled so no multi call will be emitted when we emit -# the traits. If there is such a trait, it returns it's AST. -sub has_compiler_trait_with_val($trait_list, $name, $value) { - if $trait_list { - for @($trait_list) { - my $ast := $_.ast; - if $ast.name eq $name && $ast eq $value { - $ast := 1; - return $ast; - } - } - } - return 0; -} - - -# This sub takes a list of traits, the PAST node for a declarand and a -# target PAST node. For all non-compiler-handled traits, it unshifts -# the declarand onto the call and adds it to the target node. -sub emit_traits($trait_list, $to, $declarand) { - if $trait_list { - for @($trait_list) { - my $ast := $_.ast; - unless $ast { - $ast.unshift($declarand); - $to.push($ast); - } - } - } -} - -# Local Variables: -# mode: cperl -# cperl-indent-level: 4 -# fill-column: 100 -# End: -# vim: expandtab shiftwidth=4: diff --git a/src/old/parser/expression.pir b/src/old/parser/expression.pir deleted file mode 100644 index a245f0cb076..00000000000 --- a/src/old/parser/expression.pir +++ /dev/null @@ -1,60 +0,0 @@ -## $Id$ - -=head1 TITLE - -expression.pir - Parsing of and subrules - -=head2 DESCRIPTION - -This file contains the grammar subrules for and -. These have special parsing requirements, -and are therefore written in PIR instead of as a standard -Perl 6 rule statement. - -=over 4 - -=item C - -The C method implements the Perl6::Grammar subrule. -It forwards the match object (invocant) to the operator -precedence parser to obtain an expression, and returns the -result to the caller. Any C option is passed as a -corresponding option to the operator precedence parser, which -parses expressions of tighter precedence. - -(FIXME Parrot bug RT#53296 prevents us from using :optional -on the C argument along with :slurpy :named parameters, -so we use :multi as a temporary workaround.) - -=cut - -.namespace [ "Perl6";"Grammar" ] - -.include "cclass.pasm" - -.sub "EXPR" :method :multi(_) - .param pmc adverbs :slurpy :named - .local pmc optable - - optable = get_hll_global ['Perl6';'Grammar'], "$optable" - .tailcall optable."parse"(self, 'rulename'=>'EXPR', adverbs :named :flat) -.end - -.sub "EXPR" :method :multi(_,_) - .param pmc tighter - .param pmc adverbs :slurpy :named - .local pmc optable - - optable = get_hll_global ['Perl6';'Grammar'], "$optable" - .tailcall optable."parse"(self, 'rulename'=>'EXPR', 'tighter'=>tighter, adverbs :named :flat) -.end - -=back - -=cut - -# Local Variables: -# mode: pir -# fill-column: 100 -# End: -# vim: expandtab shiftwidth=4 ft=pir: diff --git a/src/old/parser/grammar-oper.pg b/src/old/parser/grammar-oper.pg deleted file mode 100644 index 9514d6c4212..00000000000 --- a/src/old/parser/grammar-oper.pg +++ /dev/null @@ -1,204 +0,0 @@ -# Copyright (C) 2007, The Perl Foundation. -# $Id$ - -## autoincrement -proto postfix:<++> is precedence('x=') is lvalue(1) { ... } -proto postfix:<--> is equiv(postfix:<++>) is lvalue(1) { ... } -proto prefix:<++> is equiv(postfix:<++>) is lvalue(1) { ... } -proto prefix:<--> is equiv(postfix:<++>) is lvalue(1) { ... } -proto postfix: is equiv(postfix:<++>) { ... } - -## exponentiation -proto infix:<**> is precedence('w=') is assoc('right') { ... } - -## symbolic unary -proto prefix:<+> is precedence('v=') { ... } -proto prefix:<-> is equiv(prefix:<+>) { ... } -proto prefix:<~> is equiv(prefix:<+>) { ... } -proto prefix: is equiv(prefix:<+>) { ... } -proto prefix: is equiv(prefix:<+>) { ... } -proto prefix:<+^> is equiv(prefix:<+>) - is pirop('bnot') - { ... } -proto prefix:<=> is equiv(prefix:<+>) { ... } -proto prefix:<^> is equiv(prefix:<+>) { ... } -proto prefix:<\> is equiv(prefix:<+>) { ... } -proto prefix:<|> is equiv(prefix:<+>) { ... } - -## multiplicative operators -proto infix:<*> is precedence('u=') { ... } -proto infix: is equiv(infix:<*>) { ... } -proto infix:<%> is equiv(infix:<*>) { ... } -proto infix: is equiv(infix:<*>) { ... } -proto infix:<+&> is equiv(infix:<*>) { ... } -proto infix:<+^> is equiv(infix:<*>) { ... } -proto infix:«+<» is equiv(infix:<*>) { ... } -proto infix:«+>» is equiv(infix:<*>) { ... } -proto infix:<~&> is equiv(infix:<*>) { ... } -proto infix:«~<» is equiv(infix:<*>) { ... } -proto infix:«~>» is equiv(infix:<*>) { ... } -proto infix: is equiv(infix:<*>) { ... } -proto infix:
is equiv(infix:<*>) { ... } -proto infix: is equiv(infix:<*>) { ... } - -## additive operators -proto infix:<+> is precedence('t=') { ... } -proto infix:<-> is equiv(infix:<+>) { ... } -proto infix:<+|> is equiv(infix:<+>) { ... } -proto infix:<+^> is equiv(infix:<+>) { ... } -proto infix:<~|> is equiv(infix:<+>) { ... } -proto infix:<~^> is equiv(infix:<+>) { ... } -proto infix: is equiv(infix:<+>) { ... } -proto infix: is equiv(infix:<+>) { ... } - -## replication -proto infix: is precedence('s=') { ... } -proto infix: is equiv(infix:) { ... } - -## concatenation -proto infix:<~> is precedence('r=') { ... } - -## junctive and -proto infix:<&> is precedence('q=') - is assoc('list') - { ... } - -## junctive or -proto infix:<|> is precedence('p=') - is assoc('list') - { ... } -proto infix:<^> is equiv(infix:<|>) - is assoc('list') - { ... } - -## named unary -proto prefix: is precedence('o=') is subname('abs') { ... } -proto prefix: is equiv(prefix:) is subname('HOW') { ... } -proto prefix: is equiv(prefix:) is subname('WHAT') { ... } -proto prefix: is equiv(prefix:) is subname('pop') { ... } -proto prefix: is equiv(prefix:) is subname('shift') { ... } -proto prefix: is equiv(prefix:) is subname('defined') { ... } - -## nonchaining -proto infix:<..> is precedence('n=') { ... } -proto infix:<..^> is equiv(infix:<..>) { ... } -proto infix:<^..> is equiv(infix:<..>) { ... } -proto infix:<^..^> is equiv(infix:<..>) { ... } -proto infix:«<=>» is equiv(infix:<..>) { ... } -proto infix: is equiv(infix:<..>) { ... } -proto infix: is equiv(infix:<..>) { ... } -proto infix:<=:=> is equiv(infix:<..>) { ... } -proto infix: is equiv(infix:<..>) { ... } -proto infix: is equiv(infix:<..>) { ... } -proto infix: is equiv(infix:<..>) { ... } - -## chaining -proto infix:<==> is precedence('m=') is pasttype('chain') { ... } -proto infix: is equiv(infix:<==>) is pasttype('chain') { ... } -proto infix: is equiv(infix:<==>) is pasttype('chain') { ... } -proto infix:«<» is equiv(infix:<==>) is pasttype('chain') { ... } -proto infix:«<=» is equiv(infix:<==>) is pasttype('chain') { ... } -proto infix:«>» is equiv(infix:<==>) is pasttype('chain') { ... } -proto infix:«>=» is equiv(infix:<==>) is pasttype('chain') { ... } -proto infix: is equiv(infix:<==>) is pasttype('chain') { ... } -proto infix: is equiv(infix:<==>) is pasttype('chain') { ... } -proto infix: is equiv(infix:<==>) is pasttype('chain') { ... } -proto infix: is equiv(infix:<==>) is pasttype('chain') { ... } -proto infix: is equiv(infix:<==>) is pasttype('chain') { ... } -proto infix: is equiv(infix:<==>) is pasttype('chain') { ... } -proto infix: is equiv(infix:<==>) is pasttype('chain') { ... } -proto infix:<~~> is equiv(infix:<==>) is pasttype('chain') { ... } -proto infix: is equiv(infix:<==>) is pasttype('chain') { ... } -proto infix:<===> is equiv(infix:<==>) is pasttype('chain') { ... } -proto infix: is equiv(infix:<==>) is pasttype('chain') { ... } -proto infix: is equiv(infix:<==>) is pasttype('chain') { ... } -proto infix: is equiv(infix:<==>) is pasttype('chain') { ... } - -## tight and -proto infix:<&&> is precedence('l=') - is pasttype('if') - { ... } - -## tight or -proto infix:<||> is precedence('k=') - is pasttype('unless') - { ... } -proto infix:<^^> is equiv(infix:<||>) - is pasttype('xor') - { ... } -proto infix: is equiv(infix:<||>) - is pasttype('def_or') - { ... } -proto infix: is equiv(infix:<||>) - is assoc('list') - { ... } -proto infix: is equiv(infix:<||>) - is assoc('list') - { ... } - -## conditional -proto ternary: is precedence('j=') is pasttype('if') is assoc('right') { ... } - -## item assignment -proto infix:<:=> is precedence('i=') is assoc('right') is pasttype('bind') { ... } -proto infix:<::=> is equiv(infix:<:=>) { ... } -proto infix:<.=> is equiv(infix:<:=>) { ... } -proto infix:«=>» is equiv(infix:<:=>) { ... } -proto infix: is equiv(infix:<:=>) is lvalue(1) { ... } -proto infix:<&&=> is equiv(infix:<:=>) { ... } -proto infix:<||=> is equiv(infix:<:=>) { ... } - -## loose unary -proto prefix: is precedence('h=') is subname('true') { ... } -proto prefix: is equiv(prefix:) is subname('not') { ... } - -## comma -proto infix:<,> is precedence('g=') - is assoc('list') - is nullterm - { ... } -proto infix:«p5=>» is equiv(infix:<,>) is subname('infix:,') { ... } - -## list infix -proto infix: is precedence('f=') - is assoc('list') - { ... } -proto infix: is equiv(infix:) { ... } -proto infix:<...> is equiv(infix:) { ... } -proto infix: is equiv(infix:) { ... } -proto infix: is equiv(infix:) - is assoc('list') - is subname('infix:X') - { ... } - -## list assignment -proto infix:<=> is precedence('e=') - is assoc('right') - is lvalue(1) - { ... } -proto prefix:<[,]> is precedence('e=') is subname('list') {...} -proto prefix:<[&]> is equiv(prefix:<[,]>) is subname('all') {...} -proto prefix:<[|]> is equiv(prefix:<[,]>) is subname('any') {...} -proto prefix:<[^]> is equiv(prefix:<[,]>) is subname('one') {...} -proto prefix:<[||]> is equiv(prefix:<[,]>) {...} -proto prefix:<[//]> is equiv(prefix:<[,]>) {...} - -## loose and -proto infix: is precedence('d=') - is pasttype('if') - { ... } -proto infix: is equiv(infix:) { ... } - -## loose or -proto infix: is precedence('c=') - is pasttype('unless') - { ... } -proto infix: is equiv(infix:) - is pasttype('xor') - { ... } -proto infix: is equiv(infix:) { ... } - -proto infix:«<==» is precedence('b=') { ... } -proto ifnix:«==>» is equiv(infix:«<==») { ... } -proto ifnix:«<<==» is equiv(infix:«<==») { ... } -proto ifnix:«==>>» is equiv(infix:«<==») { ... } diff --git a/src/old/parser/grammar.pg b/src/old/parser/grammar.pg deleted file mode 100644 index e0b950cd363..00000000000 --- a/src/old/parser/grammar.pg +++ /dev/null @@ -1,1091 +0,0 @@ -# Copyright (C) 2007-2008, The Perl Foundation. -# $Id$ - -=begin Introduction - -This is the rules portion of the grammar for the Rakudo compiler, -an implementation of Perl 6 on Parrot. This grammar is modeled -after the STD.pm grammar that Larry Wall and others are developing, -available from L. - -Our ultimate goal is to have this grammar and STD.pm converge -with each other, to form an "official" Perl 6 grammar. But -there's a lot to do between here and that goal. For one, Parrot -doesn't yet have a rules engine that understands all of the -constructs that appear in STD.pm, such as protoregexes . -Another challenge is that the language specification itself -changes from time to time as the various implementations progress. -So, we can't just blindly copy STD.pm . - -When adding a new construct or feature to this grammar, -be sure to look at STD.pm first to see how it achieves the -result. If STD.pm's approach can be copied directly, do that. -If not, then try to get a close as possible (e.g., by using -STD.pm's names). And yes, there are times when STD.pm may -adopt things done here. But we want to keep them as close -as we can. - -In each of the rules below, the special notation C<{*}> -marks a point in the rule where a corresponding method -from Perl6::Grammar::Actions (F) -is invoked. These actions will then construct the abstract -syntax tree nodes as the source program is being parsed. - -The C<#=> markers at the ends of lines look like comments, -but they're used to distinguish multiple C<{*}> actions -within a rule. (This is how STD.pm is organized, also.) -The value following any C<#=> marker is passed as a -'key' argument to the action method invoked by C<{*}> -earlier in the line. - -Rules with only one action need no #= comment. - -=end overview - -grammar Perl6::Grammar is PCT::Grammar; - -token TOP { - {{ $P0 = get_hll_global ['Bool'], 'True' - set_global '$begin_compunit', $P0 }} - <.MARK_STATEMENT_END> - - [ $ || ] - {*} -} - - -#### whitespace, comments, pod #### - -## The token is used to match "whitespace", which includes -## things like spaces, comments, and pod comments. It also -## memoizes the last whitespace token matched into C<$!ws>, -## and short circuits if we are at the same position as the -## last ws token matched. - -token ws { - ## short circuit - [ - | - [ - | <.unsp> - | \v+ - | <.unv> - ]* - ] -} - -token unsp { - \\ <.before [\s|'#']> - [ \v | <.unv> ]* -} - -token unspacey { <.unsp>? } -token nofun { } - -token unv { - || \h+ - || ^^ <.pod_comment> - || \h* '#' [ - | '`' - | '= ' \N* - | '=' - | <.panic: "Embedded comments now require backticks"> - | \N* - ] -} - -## The rule returns true if we're immediate after -## a set of whitespace. - -token afterws { - ## - {{ $P0 = match.'to'() - $P1 = get_global '$!ws' - $P2 = $P1.'to'() - if $P0 != $P2 goto end - $P2 = $P1.'from'() - if $P0 == $P1 goto end - .return (1) - end: - }} - -} - -token pod_comment { - ^^ '=' <.unsp>? - [ - | 'begin' \h+ 'END' >> :: - [ .*? \n '=' <.unsp>? 'end' \h+ 'END' >> \N* || .* ] - | 'begin' \h+ :: - [ - || .*? \n '=' <.unsp>? 'end' \h+ $ >> \N* {*} #= tagged - || <.panic: "=begin without matching =end"> - ] - | 'begin' >> :: \h* - [ $$ || '#' || <.panic: "Unrecognized token after =begin"> ] - [ .*? \n '=' <.unsp>? 'end' >> \N* || <.panic: "=begin without =end"> ] - {*} #= anon - | :: - [ - - <.panic: "Obsolete pod format, please use =begin/=end instead"> - ]? - \N* {*} #= misc - ] -} - - -token apostrophe { - <[ ' \- ]> -} - -token identifier { - <.ident> [ <.apostrophe> <.ident> ]* -} - - -## STD.pm doesn't have a statement_block rule -- we have one -## to distinguish lists of statements that produce blocks -## from those that don't. - -rule statement_block { - {*} #= open - - {*} #= close -} - - -token lambda { '->' | '<->' } - -token pblock { [ <.ws> ]? <.ws> {*} } - -token xblock { <.ws> {*} } - - -## Blocks can also have an implied statement end if the -## closing brace is the last non-ws thing on the line. - -token block { - '{' ~ '}' - <.BLOCK_STATEMENT_END>? - {*} -} - -token BLOCK_STATEMENT_END { - [ \h* <.unv>? \n <.MARK_STATEMENT_END> ] -} - -rule statementlist { - [<.eat_terminator> ]* - {*} -} - -## The eat_terminator detects when we're at a valid -## statement termination point. A semicolon always acts as -## a valid statement end, as does the presence of any expression -## terminator. The MARK_STATEMENT_END subrule is used by other -## rules to indicate a valid statement end when a terminator -## isn't present -- e.g., a closing '}' at the end of a line -## for a . - -token terminator { - | <[ ; ) \] } ]> - | '!!' - | '-->' - | [ if | unless | while | until | for | given | when ] >> <.nofun> -} - -token stdstopper { - -} - -token eat_terminator { - || ';' - || - || - || $ - || <.panic: "Confused"> -} - -token MARK_STATEMENT_END { - {{ $P0 = match.'to'() - $P0 = clone $P0 - set_global '$!endstmt', $P0 - }} - <.ws> -} - -token AT_STATEMENT_END { - -} - - - -## Parse a single statement, which may be either a bare block -## or an expression. Any statement termination is handled by -## the calling rule. -token statement { - [ - | {*} #= control - | - [ - || {*} #= expr - || {*} #= mod_loop - || <.ws> - ? - {*} #= mod_cond - || {*} #= expr - ] - <.ws> - | {*} #= null - ] -} - -rule statement_control { - | {*} #= if_statement - | {*} #= unless_statement - | {*} #= repeat_statement - | {*} #= while_statement - | {*} #= given_statement - | {*} #= when_statement - | {*} #= default_statement - | {*} #= loop_statement - | {*} #= for_statement - | {*} #= use_statement - | {*} #= begin_statement - | {*} #= start_statement - | {*} #= end_statement - | {*} #= catch_statement - | {*} #= control_statement - | {*} #= no_statement -} - -rule if_statement { - $=[if<.nofun>] - - [ - [ || <.panic: "Please use 'elsif'"> ] - 'elsif' - ]* - [ 'else' ]? - {*} -} - -rule unless_statement { - $=[unless<.nofun>] - {*} - [ || <.panic: "unless does not take \"else\" in Perl 6; please rewrite using \"if\""> ] -} - -rule repeat_statement { - $=[repeat] - [ $=[while|until] - | $=[while|until] - ] - {*} -} - -rule while_statement { - $=[[while|until]<.nofun>] - - {*} -} - -rule given_statement { - $=[given<.nofun>] - - {*} -} - -rule when_statement { - $=[when<.nofun>] - - {*} -} - -rule default_statement { - $=[default] - - {*} -} - -rule loop_statement { - $=[loop] - $=[ - '(' - ? ';' - ? ';' - ? - ')' - ]? - - {*} -} - -rule for_statement { - $=[for<.nofun>] - - {*} -} - -rule use_statement { - $=[use] * - ? - {*} -} - -rule begin_statement { - $=[BEGIN] - - {*} -} - -rule start_statement { - $=[START] - - {*} -} - -rule end_statement { - $=[END] - - {*} -} - -rule catch_statement { - $=[CATCH] - - {*} -} - -rule control_statement { - $=[CONTROL] - - {*} -} - -rule no_statement { - 'no' ? {*} -} - -rule statement_mod_loop { - $=[[while|until|for|given]<.nofun>] {*} -} - -rule statement_mod_cond { - $=[[if|unless|when]<.nofun>] {*} -} - -rule statement_prefix { - $=[do|try|gather|contend|async|lazy]<.nofun> - - {*} -} - - -#### Subroutine and method definitions #### - -rule multi_declarator { - [ - | $=[multi|proto|only]<.nofun> [ || ] - | - ] - {*} -} - -token routine_declarator { - | $='sub' <.nofun> {*} #= sub - | $='method' <.nofun> {*} #= method - | $='submethod' <.nofun> {*} #= submethod -} - -rule multisig { - ':'?'(' ~ ')' - {*} -} - -rule routine_def { - [ ]? [ | ]* - {*} - - || <.panic: "Malformed routine definition"> -} - -rule method_def { - [ - | $=[<[ ! ^ ]>?]$=[?] [ | ]* - | * - | :: - ] - - {*} - || <.panic: "Malformed method definition"> -} - -rule trait { - [ - | - | - ] - {*} -} - -rule trait_mod { - [ - | $=[is] ? - | $=[hides] - | $=[does] - | $=[will] - | $=[of|returns] - | $=[handles] - ] - {*} -} - -token capterm { - '\\(' ')' - {*} -} - -rule capture { - - {*} -} - -token sigterm { - ':(' ~ ')' {*} -} - -rule param_sep { (','|':'|';;'|';') } - -token signature { - {*} #= open - <.ws> - [ - | - | ' | ')' | ']' | '{' | ':' > - ] ** 1 ## PGE bug - [ - [ - | - | ' | ')' | ']' | '{' | ':' > - ] - ]* - <.ws> - [ '-->' <.ws> ]? - {*} #= close -} - -rule type_declarator { - subset - - {{ - $S0 = match['name'] - match.'add_type'($S0) - }} - [ of ]? - * - [where ]? # XXX - {*} -} - -rule type_constraint { - [ - | - | - | where - | '(' ~ ')' - | [ <.before \w> ]? [ - || - || $=['/'|'!'] - ]? - ] - {*} -} - -token named_param { - ':' - [ - | '(' <.ws> - [ <.ws> ] - [ ')' || <.panic: "Unable to parse named parameter; couldn't find right parenthesis"> ] - | - ] - {*} -} - -token parameter { - * - [ - | $=['*'] - | $=[ <[ ? ! ]>? ] - | $=[ <[ ? ! ]>? ] - | 0 - .return ($I0) - }}> - ] - * - * - ? - {*} -} - -rule default_value { - '=' ?]? <.unsp>? ]* - - [ - | {*} #= dotty - | {*} #= postcircumfix - ] -} - -token postfix_prefix_meta_operator { '»' | '>>' } - -token dotty { - [ - | '.VAR' {*} #= VAR - | '.' <.unspacey> {*} #= . - | ('.' <[+*?^:=]>) <.unspacey> {*} #= .* - | '!' {*} #= ! - ] -} - - -token dottyop { - | {*} #= methodop - | {*} #= postcircumfix -} - - -token methodop { - [ - | - | - | > -# { $ ~~ /\W/ or .panic("Useless use of quotes") } - ] <.unsp>? - - [ - | '.'? <.unsp>? '(' ')' {*} #= semilist - | ':' {*} #= arglist - | {*} #= null - ] -} - - -token postcircumfix { - | '(' ')' {*} #= ( ) - | '[' ']' {*} #= [ ] - | '{' '}' {*} #= { } - | {*} #= < > - | {*} #= < > -} - - -# XXX Note that 'self' here should be a term. -token noun { - | {*} #= fatarrow - | {*} #= variable - | {*} #= package_declarator - | {*} #= scope_declarator - | {*} #= routine_declarator - | {*} #= multi_declarator - | {*} #= regex_declarator - | {*} #= type_declarator - | {*} #= enum_declarator - | {*} #= circumfix - | {*} #= statement_prefix - | {*} #= dotty - | {*} #= value - | 'self' >> {*} #= self - | {*} #= term - | {*} #= capterm - | {*} #= sigterm - | {*} #= colonpair -} - - -token term { - [ - | 'VAR(' ')' {*} #= VAR - | {*} #= term_START - | - [ - | <.unsp>? '.'? '(' ')' {*} #= func args - | :: {*} #= noarg - ] - | {*} #= typename - | - [ - | {*} #= args - | :: {*} #= noarg - ] - | \s {*} #= sigil - | '...' {*} #= ... - | '**' {*} #= ** - | '*' {*} #= * - ] -} - - -rule term_START { - $=[START] {*} -} - - -token args { - | \s {*} #= listop args - | <.unsp>? '.'? '(' ')' {*} #= func args -} - -## XXX: cheat until we get term:pi, term:rand, term:undef, etc. -token named_0ary { - | [pi|rand|undef|nothing|time|next|last|continue|break|Inf|NaN] >> - | ['...'|'???'|'!!!'] -} - -rule package_declarator { - | $=[class|grammar|module|package|role] {*} #= open - {*} #= package_def - | 'does' {*} #= does -} - - -rule package_def { - [ - - {{ - $P0 = match['def_module_name'] - $P0 = $P0[0] - $P0 = $P0['longname'] - $S0 = $P0['name'] - match.'add_type'($S0) - }} - ]? - * - {*} #= open - [ - | {*} #= block - | - ';' {*} #= statement_block - | {*} #= panic - ] -} - - -rule enum_declarator { - 'enum' - [ - :: - {{ - $P0 = match['name'] - $S0 = $P0[0] - match.'add_type'($S0) - }} - ]? - - {*} #= circumfix -} - -rule scope_declarator { - $=[my|our|state|constant|has] - {{ - # XXX Becomes context variable. - $S0 = match['sym'] - $P1 = get_hll_global ['Perl6';'Grammar';'Actions'], '@?SCOPE' - unshift $P1, $S0 - }} - - {{ - # XXX Goes away when we have context vars. - $P1 = get_hll_global ['Perl6';'Grammar';'Actions'], '@?SCOPE' - $S0 = shift $P1 - }} - {*} -} - -rule scoped { - [ - | - | - | + - | - ] {*} - || <.panic: "Malformed declaration"> # STD.pm: <.panic: "Malformed \"$+SCOPE\" declaration"> -} - -token declarator { - [ - | - | '(' ~ ')' * - | - | - | - | - ] - {*} -} - -token variable_declarator { - - <.ws> - * - * - {*} -} - -token constant_declarator { - - - $P0 = get_hll_global ['Perl6';'Grammar';'Actions'], '@?SCOPE' - $S0 = $P0[0] - $I0 = $S0 == 'constant' - .return ($I0) - }}> - .Str) }> - $S0 = match['identifier'] - .tailcall match.'is_type'($S0) - }}> - <.ws> - * - {*} -} - - -token variable { - - [ - || '.' - [ [<.unsp> | '\\']? ]? - {*} #= methcall - || '&' ? {*} #= subnoun - || ? {*} #= desigilname - || {*} #= special_variable - || $=[\d+] {*} #= $0 - || {*} #= $<> - ] -} - -token sigil { '$' | '@' | '%' | '&' | '@@' } - -token twigil { <[.!^:*+?=]> } - -token desigilname { - [ - | - | - ] -} - -token special_variable { - $=[ '$/' | '$!' | '$¢' ] {*} -} - -token circumfix { - | '(' ')' {*} #= ( ) - | '[' ']' {*} #= [ ] - | > {*} #= { } - | '(' ')' {*} #= $( ) - | {*} #= quote - | {*} #= quote -} - -token def_module_name { - - $=[ - :dba('generic role') - - '[' ~ ']' - ]? -} - -token module_name { - - [ - - :dba('generic role') - '[' ~ ']' - ]? -} - -token longname { - * -} - -token name { - | * - | + -} - -token morename { - '::' - [ - > - [ - | - | '(' ')' - ] - ]? -} - -token subshortname { - + -} - -token category { 'infix' | 'prefix' | 'postfix' | 'circumfix' | 'postcircumfix' | 'trait_mod' } - -## used internally to convert p6 opnames to internal ones -regex opname { - ':' - [ '<<' \s* [ ([\S+]**[\s+]) \s* ] '>>' - | '«' \s* [ ([\S+]**[\s+]) \s* ] '»' - | '<' \s* [ ([\S+]**[\s+]) \s* ] '>' - ] -} - -token value { - | {*} #= quote - | {*} #= number -} - -token typename { - - - {*} -} - -token fulltypename { - - <.unsp>? [ ]? - <.ws> [ 'of' <.ws> ]? - {*} -} - - -## Quoting is tricky -- the subrule is in -## F . -token quote { - [ - | <.before \'> - | <.before '"' > - | <.before '/'> - | [m|rx] <.nofun> <.ws> - [ [':P5'|':Perl5'] <.nofun> <.ws> - | - ] - | qq [ <.ws> ':' ]? - [ w <.nofun> <.ws> - | $=[x?] <.nofun> <.ws> - ] - | q [ <.ws> ':' ]? - [ q <.nofun> <.ws> - | w <.nofun> <.ws> - | PIR <.nofun> <.ws> - | $=[x?] <.nofun> <.ws> - ] - | Q [ <.ws> ':' ]? - [ PIR <.nofun> <.ws> - | q <.nofun> <.ws> - | qq <.nofun> <.ws> - | b <.nofun> <.ws> - | $=[x?] <.nofun> <.ws> - ] - | s <.nofun> <.ws> - <.panic: 's/// not implemented, try .subst as workaround'> - ] - {*} -} - - -token number { - [ {*} #= dec_number - | {*} #= integer - | {*} #= rad_number - ] -} - -token integer { - [ - | 0 [ b <[01]>+ [ _ <[01]>+ ]* - | o <[0..7]>+ [ _ <[0..7]>+ ]* - | x <[0..9a..fA..F]>+ [ _ <[0..9a..fA..F]>+ ]* - | d \d+ [ _ \d+]* - | \d+[_\d+]* - {{ say "Leading 0 does not indicate octal in Perl 6" }} # FIXME - ] - | \d+[_\d+]* - ] - {*} -} - -token escale { - <[Ee]> <[+\-]>? \d+[_\d+]* -} - -# careful to distinguish from both integer and 42.method -token dec_number { - [ - | '.' \d+[_\d+]* <.escale>? - | \d+[_\d+]* '.' \d+[_\d+]* <.escale>? - | \d+[_\d+]* <.escale> - ] - {*} -} - -token radint { - [ - | {*} #= integer - | # this alternation is a subset of rad_number - ':' $=[\d+] <.unsp>+ - :: '<' - $=[<[0..9 a..z A..Z _]>]+ - [ '*' '**' ]? - '>' - {*} #= rad_number - ] -} - -token rad_number { - ':' $=[\d+] <.unsp>? - :: - [ - || '<' - $=[<[0..9 a..z A..Z _]>]+ - $=[ '.' <[0..9 a..z A..Z _]>+ ]? - [ '*' '**' ]? - '>' - || - || - ] - {*} -} - - -rule regex_declarator { - $=[regex|token|rule] - {*} -} - -rule regex_def { - ? - {*} - || <.panic: "Malformed regex definition"> -} - -token regex_block { - - <.BLOCK_STATEMENT_END>? - {*} -} - - -## S05 shows semilist as being a list of statements, in order -## to support multidimensional argument lists. For now we -## just handle a single-dimensional argument list. -rule semilist { - ? - {*} -} - -token arglist { - [ - | - | ' {*} #= false - | $=[ <.unsp>? ]? {*} #= value - | {*} #= structural - | ? {*} #= varname - ] -} - -#### expressions and operators #### - -## The EXPR rule is our entry point into the operator -## precedence parser. At the moment the operator -## tokens are defined in F, -## using a prototype function syntax (because PGE doesn't -## yet support protoregexes). When the operator precedence -## parser needs a term, it gets it by calling the 'term' -## token above. - -## rule EXPR is optable { ... } - -proto 'term:' is precedence('z=') - is parsed(&expect_term) - { ... } - -proto 'term:->' is equiv(term:) - is parsed(&expect_term) - is skipkey(0) - { ... } - -proto 'close:<->' is equiv(term:) { ... } diff --git a/src/old/parser/methods.pir b/src/old/parser/methods.pir deleted file mode 100644 index f920dd7db5c..00000000000 --- a/src/old/parser/methods.pir +++ /dev/null @@ -1,172 +0,0 @@ -## $Id$ - -=head1 TITLE - -methods.pir - Methods on Perl6::Grammar. - -=head2 DESCRIPTION - -STD.pm contains various methods. This file implements some of them. - -=over 4 - -=item C - -Registers a type in the namespace. - -=cut - -.namespace [ "Perl6";"Grammar" ] -.sub "add_type" :method - .param string name - - # :: is really anonymous, so do nothing. - if name != '::' goto non_anon - .return () - non_anon: - - # Parse name. - .local pmc ns - .local string short_name - $P0 = compreg 'perl6' - ns = $P0.'parse_name'(name) - short_name = pop ns - - # Check if the symbol already exists in the NS; if so we record it as - # an existing type. - $P0 = get_hll_global ns, short_name - if null $P0 goto no_namespace - $S0 = typeof $P0 - unless $S0 == 'NameSpace' goto type_exists - - no_namespace: - # Work outwards to find a block defining a package and put the type - # there. XXX This makes it too visible for lexical types, but if we - # assume lexical rather than package scope then we will fail various - # tests/code. - .local pmc blocks, it, cur_block - blocks = get_hll_global ['Perl6';'Grammar';'Actions'], '@?BLOCK' - it = iter blocks - it_loop: - unless it goto it_loop_end - cur_block = shift it - $P0 = cur_block['sym'] - if null $P0 goto it_loop - if $P0 == '' goto it_loop - it_loop_end: - $P0 = cur_block.'symbol'(name) - if $P0 goto type_exists - cur_block.'symbol'(name, 'does_abstraction'=>1) - - # We also need to register it under it's fully qualified name at the outermost - # block. - .local pmc bottom_block - $I0 = elements blocks - dec $I0 - bottom_block = blocks[$I0] - $P0 = get_hll_global ['Perl6';'Grammar';'Actions'], '@?NS' - unless $P0 goto no_ns - $S0 = $P0[0] - concat $S0, '::' - name = concat $S0, name - $P0 = bottom_block.'symbol'(name) - if $P0 goto type_exists - no_ns: - bottom_block.'symbol'(name, 'does_abstraction'=>1) - - # Record that a type was added or already existed. - $P0 = box 0 - goto set_redecl - type_exists: - $P0 = box 1 - set_redecl: - setprop self, '$!type_redecl', $P0 -.end - - -=item C - -Checks if the name we have been passed represents a type. - -=cut - -.sub 'is_type' :method - .param string full_name - - # Get blocks. - .local pmc blocks - blocks = get_hll_global [ 'Perl6' ; 'Grammar' ; 'Actions' ], '@?BLOCK' - - # If it starts with ::, it's a declaration; note it in the block. - $S0 = substr full_name, 0, 2 - if $S0 != '::' goto not_decl - $S0 = substr full_name, 2 - $P0 = blocks[0] - $P0.'symbol'($S0, 'does_abstraction'=>1) - goto type_ok - not_decl: - - # Look in @?BLOCK first. - .local pmc block_it, block, sym_info - block_it = iter blocks - block_it_loop: - unless block_it goto block_it_loop_end - block = shift block_it - sym_info = block.'symbol'(full_name) - if null sym_info goto block_it_loop - $P0 = sym_info['does_abstraction'] - if null $P0 goto block_it_loop - unless $P0 goto block_it_loop - goto type_ok - block_it_loop_end: - - # Parse name and look for the symbol in the namespace, then check if - # it's a type. - .local pmc compiler_obj, check_ns, check_symbol - .local string short_name - compiler_obj = get_hll_global [ 'Perl6' ], 'Compiler' - check_ns = compiler_obj.'parse_name'(full_name) - short_name = pop check_ns - check_symbol = get_hll_global check_ns, short_name - if null check_symbol goto fail_it - $I0 = does check_symbol, 'Abstraction' - if $I0 goto type_ok - # XXX The following should be covered by a check for does Abstraction - $I0 = isa check_symbol, 'P6protoobject' - if $I0 goto type_ok - $I0 = isa check_symbol, 'Perl6Role' - if $I0 goto type_ok - $P0 = class check_symbol - $P0 = getprop 'enum', $P0 - if null $P0 goto not_enum - if $P0 goto type_ok - not_enum: - goto fail_it - - type_ok: - .return (1) - fail_it: - .return (0) -.end - - -=item type_redeclaration - -Checks if the most recently added type was a re-declaration. - -=cut - -.sub 'type_redeclaration' :method - $P0 = getprop '$!type_redecl', self - .return ($P0) -.end - -=back - -=cut - -# Local Variables: -# mode: pir -# fill-column: 100 -# End: -# vim: expandtab shiftwidth=4 ft=pir: diff --git a/src/old/parser/quote_expression.pir b/src/old/parser/quote_expression.pir deleted file mode 100644 index 7896955e8fd..00000000000 --- a/src/old/parser/quote_expression.pir +++ /dev/null @@ -1,501 +0,0 @@ -# Copyright (C) 2007-2008, The Perl Foundation. -# $Id$ - -.include 'cclass.pasm' - -.namespace ['Perl6';'Grammar'] - -.sub '' :anon :load :init - .local pmc brackets - brackets = box unicode:"<>[](){}\xab\xbb\u0f3a\u0f3b\u0f3c\u0f3d\u169b\u169c\u2045\u2046\u207d\u207e\u208d\u208e\u2329\u232a\u2768\u2769\u276a\u276b\u276c\u276d\u276e\u276f\u2770\u2771\u2772\u2773\u2774\u2775\u27c5\u27c6\u27e6\u27e7\u27e8\u27e9\u27ea\u27eb\u2983\u2984\u2985\u2986\u2987\u2988\u2989\u298a\u298b\u298c\u298d\u298e\u298f\u2990\u2991\u2992\u2993\u2994\u2995\u2996\u2997\u2998\u29d8\u29d9\u29da\u29db\u29fc\u29fd\u3008\u3009\u300a\u300b\u300c\u300d\u300e\u300f\u3010\u3011\u3014\u3015\u3016\u3017\u3018\u3019\u301a\u301b\u301d\u301e\ufd3e\ufd3f\ufe17\ufe18\ufe35\ufe36\ufe37\ufe38\ufe39\ufe3a\ufe3b\ufe3c\ufe3d\ufe3e\ufe3f\ufe40\ufe41\ufe42\ufe43\ufe44\ufe47\ufe48\ufe59\ufe5a\ufe5b\ufe5c\ufe5d\ufe5e\uff08\uff09\uff3b\uff3d\uff5b\uff5d\uff5f\uff60\uff62\uff63" - set_global '$!brackets', brackets -.end - -.sub 'opener' :method - .local string brackets - $P0 = get_global '$!brackets' - brackets = $P0 - - .local pmc mob - .local string target - .local int pos - (mob, pos, target) = self.'new'(self) - $S0 = substr target, pos, 1 - $I0 = index brackets, $S0 - if $I0 < 0 goto fail - $I0 = $I0 % 2 - if $I0 goto fail - inc pos - mob.'to'(pos) - fail: - .return (mob) -.end - -.sub 'peek_brackets' :method - .param string target - .param int pos - .local string brackets, start, stop - - $P0 = get_global '$!brackets' - brackets = $P0 - - start = substr target, pos, 1 - if start == ':' goto err_colon_delim - stop = start - $I0 = index brackets, start - if $I0 < 0 goto end - $I1 = $I0 % 2 - unless $I1 goto bracket_valid - self.'panic'("Using a closing delimiter for an opener is reserved") - goto end - bracket_valid: - inc $I0 - stop = substr brackets, $I0, 1 - .local int len - len = 0 - bracket_loop: - inc pos - inc len - $S0 = substr target, pos, 1 - if $S0 == start goto bracket_loop - if len == 1 goto end - start = repeat start, len - stop = repeat stop, len - end: - .return (start, stop) - err_colon_delim: - self.'panic'("Colons cannot be used as delimiters in quoting constructs") -.end - - -.sub 'quote_expression' :method - .param string flags - .param pmc options :slurpy :named - - ## create a new match object - .local pmc mob - .local int pos - .local string target - (mob, pos, target) = self.'new'(self) - - ## get action object - .local pmc action - action = options['action'] - - ## set up options based on flags - .local pmc flagarray, it - flagarray = split ' ', flags - it = iter flagarray - iter_loop: - unless it goto iter_end - .local string oname - oname = shift it - oname = substr oname, 1 - options[oname] = 1 - if oname == 'ww' goto opt_ww - if oname == 'w' goto opt_w - if oname == 'qq' goto opt_qq - if oname == 'b' goto opt_b - goto iter_loop - opt_ww: - opt_w: - options['wsstop'] = 1 - goto iter_loop - opt_qq: - options['s'] = 1 - options['a'] = 1 - options['h'] = 1 - options['f'] = 1 - options['c'] = 1 - options['b'] = 1 - opt_b: - options['q'] = 1 - goto iter_loop - iter_end: - - .local string start, stop - (start, stop) = self.'peek_brackets'(target, pos) - - ## determine pos, lastpos - $I0 = length start - pos += $I0 - .local int stoplen, lastpos, wsstop - stoplen = length stop - wsstop = options['wsstop'] - lastpos = length target - lastpos -= stoplen - options['stop'] = stop - - .local pmc quote_regex - $I0 = options['regex'] - if $I0 goto regex_start - $I0 = options['PIR'] - if $I0 goto pir_start - goto word_start - - regex_start: - .local string key - key = 'quote_regex' - .local pmc regexparse - ## handle :regex parsing - regexparse = get_root_global ['parrot';'PGE';'Perl6Regex'], 'regex' - $I0 = options['P5'] - unless $I0 goto have_regexparse - regexparse = get_root_global ['parrot';'PGE';'P5Regex'], 'p5regex' - key = 'quote_p5regex' - have_regexparse: - mob.'to'(pos) - quote_regex = regexparse(mob, options :flat :named) - unless quote_regex goto fail - pos = quote_regex.'to'() - mob[key] = quote_regex - goto succeed - - pir_start: - ## scan to closing brackets - $I0 = index target, stop, pos - if $I0 < 0 goto fail - .local string pir - $I1 = $I0 - pos - pir = substr target, pos, $I1 - pos = $I0 - key = 'quote_pir' - mob[key] = pir - goto succeed - - ## handle word parsing - word_start: - ## set up escapes based on flags - .local string escapes - escapes = '' - $I0 = options['s'] - unless $I0 goto escape_s_done - escapes = '$' - escape_s_done: - $I0 = options['c'] - unless $I0 goto escape_c_done - escapes .= '{' - escape_c_done: - have_escapes: - options['escapes'] = escapes - - .local int optww - optww = options['ww'] - unless optww goto have_wwopts - escapes .= '#' - options['escapes'] = escapes - .local pmc wwsingleopts, wwdoubleopts, hashclass - hashclass = get_root_namespace ['parrot';'Hash'] - wwsingleopts = new hashclass - wwsingleopts['q'] = 1 - wwsingleopts['stop'] = "'" - wwsingleopts['action'] = action - ## FIXME: RT#48112 -- currently 'clone' on a Hash can't - ## handle null entries (and does a deepcopy), so we're - ## using an iterator to do it. - ## wwdoubleopts = clone options - wwdoubleopts = new hashclass - .local pmc it2 - it2 = iter options - iter2_loop: - unless it2 goto iter2_end - $S0 = shift it2 - $P0 = options[$S0] - wwdoubleopts[$S0] = $P0 - goto iter2_loop - iter2_end: - wwdoubleopts['stop'] = '"' - wwdoubleopts['wsstop'] = 0 - have_wwopts: - - .local pmc quote_concat - quote_concat = root_new ['parrot';'ResizablePMCArray'] - - unless wsstop goto word_plain - word_loop: - unless optww goto word_ws_plain - mob.'to'(pos) - $P0 = mob.'ws'() - unless $P0 goto word_ws_plain - pos = $P0.'to'() - word_ws_plain: - pos = find_not_cclass .CCLASS_WHITESPACE, target, pos, lastpos - if pos > lastpos goto fail - $S0 = substr target, pos, stoplen - if $S0 == stop goto word_succeed - if pos >= lastpos goto fail - unless optww goto word_plain - word_shell: - $S0 = substr target, pos, 1 - if $S0 == '"' goto word_shell_double - if $S0 != "'" goto word_plain - word_shell_single: - inc pos - mob.'to'(pos) - $P0 = mob.'quote_concat'(wwsingleopts) - unless $P0 goto fail - push quote_concat, $P0 - pos = $P0.'to'() - inc pos - goto word_loop - word_shell_double: - inc pos - mob.'to'(pos) - $P0 = mob.'quote_concat'(wwdoubleopts) - unless $P0 goto fail - push quote_concat, $P0 - pos = $P0.'to'() - inc pos - goto word_loop - word_plain: - mob.'to'(pos) - $P0 = mob.'quote_concat'(options) - unless $P0 goto fail - push quote_concat, $P0 - pos = $P0.'to'() - goto word_loop - word_succeed: - key = 'quote_concat' - mob[key] = quote_concat - - succeed: - pos += stoplen - mob.'to'(pos) - if null action goto succeed_done - $I0 = can action, 'quote_expression' - unless $I0 goto succeed_done - action.'quote_expression'(mob, key) - succeed_done: - .return (mob) - fail: - mob.'to'(-1) - .return (mob) -.end - - -.sub 'quote_concat' :method - .param pmc options - - ## create a new match object - .local pmc mob - .local int pos - .local string target - (mob, pos, target) = self.'new'(self) - - ## determine pos, lastpos - .local string stop - .local int stoplen, lastpos, wsstop - stop = options['stop'] - wsstop = options['wsstop'] - stoplen = length stop - lastpos = length target - lastpos -= stoplen - - .local string escapes - escapes = options['escapes'] - - .local pmc quote_term - quote_term = new 'ResizablePMCArray' - - term_loop: - mob.'to'(pos) - $P0 = mob.'quote_term'(options) - unless $P0 goto fail - push quote_term, $P0 - pos = $P0.'to'() - if pos > lastpos goto fail - $S0 = substr target, pos, stoplen - if $S0 == stop goto succeed - unless wsstop goto term_loop - $I0 = is_cclass .CCLASS_WHITESPACE, target, pos - unless $I0 goto term_loop - succeed: - ## save the array of captured terms - mob['quote_term'] = quote_term - mob.'to'(pos) - ## call any related {*} actions - .local pmc action - action = options['action'] - if null action goto succeed_done - $I0 = can action, 'quote_concat' - unless $I0 goto succeed_done - action.'quote_concat'(mob) - succeed_done: - .return (mob) - fail: - mob.'to'(-1) - .return (mob) -.end - - -.sub 'quote_term' :method - .param pmc options - - .local pmc action - action = options['action'] - - .local pmc mob - .local int pos - .local string target - (mob, pos, target) = self.'new'(self) - - .local string leadchar, escapes - escapes = options['escapes'] - leadchar = substr target, pos, 1 - $I0 = index escapes, leadchar - if $I0 < 0 goto term_literal - if leadchar == '$' goto term_scalar - if leadchar == '{' goto term_closure - term_literal: - mob.'to'(pos) - $P0 = mob.'quote_literal'(options) - unless $P0 goto fail - pos = $P0.'to'() - mob['quote_literal'] = $P0 - .local string key - key = 'literal' - goto succeed - - term_scalar: - mob.'to'(pos) - $P0 = mob.'variable'('action'=>action) - unless $P0 goto err_scalar - pos = $P0.'to'() - key = 'variable' - mob[key] = $P0 - goto succeed - - term_closure: - mob.'to'(pos) - $P0 = mob.'circumfix'('action'=>action) - unless $P0 goto fail - pos = $P0.'to'() - key = 'circumfix' - mob[key] = $P0 - goto succeed - - succeed: - mob.'to'(pos) - if null action goto succeed_done - $I0 = can action, 'quote_term' - unless $I0 goto succeed_done - action.'quote_term'(mob, key) - succeed_done: - .return (mob) - - fail: - mob.'to'(-1) - .return (mob) - - err_scalar: - mob.'to'(pos) - mob.'panic'("Can't use $ as non-variable in interpolated string") - .return (mob) -.end - - -.sub 'quote_literal' :method - .param pmc options - - .local pmc mob - .local int pos - .local string target - (mob, pos, target) = self.'new'(self) - - .local string stop, stop1 - .local int stoplen, lastpos, wsstop - stop = options['stop'] - wsstop = options['wsstop'] - stop1 = substr stop, 0, 1 - stoplen = length stop - lastpos = length target - lastpos -= stoplen - - .local string escapes - .local int optq, optb - escapes = options['escapes'] - optq = options['q'] - optb = options['b'] - - .local string literal - literal = '' - - scan_loop: - if pos > lastpos goto fail - $S0 = substr target, pos, stoplen - if $S0 == stop goto succeed - unless wsstop goto scan_loop_1 - $I0 = is_cclass .CCLASS_WHITESPACE, target, pos - if $I0 goto succeed - scan_loop_1: - if pos >= lastpos goto fail - - scan_char: - .local string litchar - litchar = substr target, pos, 1 - ## if we've reached an escape char, we're done - $I0 = index escapes, litchar - if $I0 >= 0 goto succeed - ## if this isn't an interpolation, add the char - unless optq goto add_litchar - if litchar != "\\" goto add_litchar - ## okay, we have a backslash, let's process it - .local string backchar - $I0 = pos + 1 - backchar = substr target, $I0, 1 - ## handle :q options, \\ and \+stop - if backchar == "\\" goto add_backchar - if backchar == stop1 goto add_backchar - unless optb goto add_litchar - ## handle :b options - $I0 = index "0abefnrtxco123456789", backchar - if $I0 < 0 goto add_backchar - if $I0 >= 11 goto fail_backchar_digit - if $I0 >= 8 goto scan_xco - litchar = substr "\0\a\b\e\f\n\r\t", $I0, 1 - if $I0 >= 1 goto add_litchar2 - ## peek ahead for octal digits after \0 - $I0 = pos + 2 - $S0 = substr target, $I0, 1 - $I0 = index "01234567", $S0 - if $I0 >= 0 goto fail_backchar_digit - add_litchar2: - pos += 2 - literal .= litchar - goto scan_loop - add_backchar: - literal .= backchar - pos += 2 - goto scan_loop - add_litchar: - literal .= litchar - inc pos - goto scan_loop - - scan_xco: - ## lean on PGE to handle \x, \c, and \o escapes. - $P0 = get_root_global['parrot';'PGE';'Perl6Regex'], 'p6escapes' - $P1 = $P0(mob, 'pos'=>pos) - unless $P1 goto fail - $S0 = $P1.'ast'() - literal .= $S0 - pos = $P1.'to'() - goto scan_loop - - succeed: - mob.'!make'(literal) - mob.'to'(pos) - .return (mob) - fail_backchar_digit: - self.'panic'('\123 form deprecated, use \o123 instead') - fail: - mob.'to'(-1) - .return (mob) -.end - - -# Local Variables: -# mode: pir -# fill-column: 100 -# End: -# vim: expandtab shiftwidth=4 ft=pir: diff --git a/src/old/setting/Any-list.pm b/src/old/setting/Any-list.pm deleted file mode 100644 index 42f0512957f..00000000000 --- a/src/old/setting/Any-list.pm +++ /dev/null @@ -1,219 +0,0 @@ -class Any is also { - multi method end() is export { $.list.elems - 1; } - - multi method first(Code $test) { - return $_ if $test($_) for @.list; - - fail('No values matched'); - } - - our List multi method grep($test) { - gather { - take $_ if $_ ~~ $test for @.list; - } - } - - our Str multi method join($separator = '') { - Q:PIR { - $P0 = self.'list'() - $P0.'!flatten'() - $P1 = find_lex '$separator' - $S1 = $P1 - $S0 = join $S1, $P0 - %r = 'prefix:~'($S0) - } - } - - our List multi method map(*&expr) { - return gather { - my $arity = &expr.arity || 1; - my @args; - for @.list { - ## We have to use PIR's 'push' here, because map can - ## mutate the elements of the list, and @args.push() - ## results in @args getting copies of the elements. - ## This may all get fixed when we come up with a way - ## to do partial bindings and not have to check .arity - ## or .count . - Q:PIR { - $P0 = find_lex '@args' - $P1 = find_lex '$_' - push $P0, $P1 - }; - if (@args == $arity) { - take &expr(|@args); - @args = (); - } - } - } - } - - multi method pick($num is copy = 1, :$replace) { - - $num .= floor; - - if ($num == 1) { - return @.list[floor(@.list.elems.rand)]; - } - - my @l; - if ($replace) { - @l := @.list; - } - else { - @l = @.list; - } - - gather { - while ($num > 0 and @l.elems > 0) { - my $idx = floor(@l.elems.rand()); - take @l[$idx]; - @l.splice($idx,1) unless $replace; - --$num; - } - } - } - - multi method pick(Whatever $, :$replace) { - die "Infinite lazy pick not implemented" if $replace; - @.pick(@.elems); - } - - # RT #63700 - parse failed on &infix: - multi method max( $values: Code $by = sub { $^a cmp $^b } ) { - my @list = $values.list; - return -Inf unless @list.elems; - if $by.arity < 2 { - my $transform = $by; - $by := sub { $transform($^a) cmp $transform($^b) }; - } - my $res = @list.shift; - for @list -> $x { - if (&$by($res, $x) < 0) { - $res = $x; - } - } - $res; - }; - - # RT #63700 - parse failed on &infix: - multi method min( $values: Code $by = sub { $^a cmp $^b } ) { - my @list = $values.list; - return +Inf unless @list.elems; - if $by.arity < 2 { - my $transform = $by; - $by := sub { $transform($^a) cmp $transform($^b) }; - } - my $res = @list.shift; - for @list -> $x { - if (&$by($res, $x) > 0) { - $res = $x; - } - } - $res; - }; - - - our List multi method pairs(*@indices) is export { - gather { - if @indices { - for (@.list.keys Z @.list) -> $key, $val is rw { - take ($key => $val) if $key ~~ any(@indices); - } - } else { - for (@.list.keys Z @.list) -> $key, $val is rw { - take ($key => $val) - } - } - } - } - - our List multi method kv() { - @.keys Z @.values - } - - multi method reduce(Code $expression is rw) { - my Int $arity = $expression.count; - fail('Cannot reduce() using a unary or nullary function.') - if $arity < 2; - - my $l := @.list; - - fail('Cannot reduce() empty list') unless +$l; - - my @args; - for $l { - @args.push($_); - if (@args == $arity) { - my $res = $expression.(|@args); - @args = ($res); - } - } - if @args > 1 { - if @args < $expression.arity { - warn (@args -1) ~ " trailing item(s) in reduce"; - } else { - return $( $expression.(|@args) ); - } - } - return @args[0]; - } - - method reverse() { - my @result; - for @.list { - @result.unshift($_); - } - return @result; - } -} - -multi first(Code $test, *@values) { - @values.first($test) -} - -our List multi grep($test, *@values) { - @values.grep($test) -} - -our Str multi join(Str $separator = '', *@values) { - @values.join($separator) -} - -our List multi sub kv(*@values) is export { - @values.kv(); -} - -our List multi sub kv(:@array) is export { - @array.kv(); -} - -our List multi map(Code $expr, *@values) { - @values.map($expr) -} - -multi pick(Int $num, :$replace, *@values) { - @values.pick($num, :$replace); -} - -multi pick(Whatever $, :$replace, *@values) { - @values.pick(*,:$replace); -} - -multi max(Code $by, *@values) { - @values.max($by); -} - -multi min(Code $by, *@values) { - @values.min($by); -} - -multi reduce(Code $expression, *@values) { - @values.reduce($expression); -} - -multi reverse(*@values) { - @values.reverse; -} - -# vim: ft=perl6 diff --git a/src/old/setting/Any-num.pm b/src/old/setting/Any-num.pm deleted file mode 100644 index e0e338c2bc4..00000000000 --- a/src/old/setting/Any-num.pm +++ /dev/null @@ -1,427 +0,0 @@ -class Any is also { - multi method exp() { - self.Num.exp; - } - - multi method abs { - Q:PIR { - $N0 = self - $N0 = abs $N0 - %r = box $N0 - } - } - - our Int multi method ceiling() is export { - Q:PIR { - $N0 = self - $I0 = ceil $N0 - %r = box $I0 - } - } - - our Str multi method chr() is export { - Q:PIR { - $I0 = self - $S0 = chr $I0 - %r = 'prefix:~'($S0) - } - } - - multi method cis() is export { - (1.0).unpolar(self) - } - - our Int multi method floor() is export { - Q:PIR { - $N0 = self - $I0 = floor $N0 - %r = box $I0 - } - } - - our Num method rand() { - Q:PIR { - $N0 = self - $N1 = rand $N0 - %r = box $N1 - } - } - - multi method roots($n) { - $.Complex.roots($n); - } - - our Int multi method round() is export { - Q:PIR { - $N0 = self - $N0 = $N0 + 0.5 - $I0 = floor $N0 - %r = box $I0 - } - } - - multi method sqrt() { - self.Num.sqrt; - } - - # Used by the :Trig subs and methods in the Int and Num classes. - our multi method !to-radians($base) { - given $base { - when /:i ^d/ { self * pi/180.0 } # Convert from degrees. - when /:i ^g/ { self * pi/200.0 } # Convert from gradians. - when /:i ^r/ { self } # Convert from radians. - when Num { self * 2.0 * pi } # Convert from revolutions. - default { die "Unable to convert to base: $base" } - } - } - - multi method log() { - $.Num.log(); - } - - multi method log($base) { - $.Num.log($base); - } - - multi method log10() { - $.Num.log10(); - } - - our multi method !from-radians($base) { - given $base { - when /:i ^d/ { self * 180/pi } # Convert to degrees. - when /:i ^g/ { self * 200/pi } # Convert to gradians. - when /:i ^r/ { self } # Convert to radians. - when Num { self /(2 * pi) } # Convert to revolutions. - default { die "Unable to convert to base: $base" } - } - } - - our Num multi method sin($base = 'radians') { - self.Num.sin($base); - } - - our Num multi method cos($base = 'radians') { - self.Num.cos($base); - } - - our Num multi method tan($base = 'radians') { - self.Num.tan($base); - } - - # Having Any.sec breaks t/spec/S32-io/IO-Socket-INET.t ??? - # our Num multi method sec($base = 'radians') is export { - # self.Num.sec($base); - # } - - our Num multi method cosec($base = 'radians') { - self.Num.cosec($base); - } - - our Num multi method cotan($base = 'radians') { - self.Num.cotan($base); - } - - our Num multi method sinh($base = 'radians') { - self.Num.sinh($base); - } - - our Num multi method cosh($base = 'radians') { - self.Num.cosh($base); - } - - our Num multi method tanh($base = 'radians') { - self.Num.tanh($base); - } - - our Num multi method sech($base = 'radians') { - self.Num.sech($base); - } - - our Num multi method cosech($base = 'radians') { - self.Num.cosech($base); - } - - our Num multi method cotanh($base = 'radians') { - self.Num.cotanh($base); - } - - our Num multi method asin($base = 'radians') { - self.Num.asin($base); - } - - our Num multi method acos($base = 'radians') { - self.Num.acos($base); - } - - our Num multi method atan($base = 'radians') { - self.Num.atan($base); - } - - our Num multi method atan2($x = 1, $base = 'radians') { - self.Num.atan2($x, $base); - } - - our Num multi method asec($base = 'radians') { - self.Num.asec($base); - } - - our Num multi method acosec($base = 'radians') { - self.Num.acosec($base); - } - - our Num multi method acotan($base = 'radians') { - self.Num.acotan($base); - } - - our Num multi method asinh($base = 'radians') { - self.Num.asinh($base); - } - - our Num multi method acosh($base = 'radians') { - self.Num.acosh($base); - } - - our Num multi method atanh($base = 'radians') { - self.Num.atanh($base); - } - - our Num multi method asech($base = 'radians') { - self.Num.asech($base); - } - - our Num multi method acosech($base = 'radians') { - self.Num.acosech($base); - } - - our Num multi method acotanh($base = 'radians') { - self.Num.acotanh($base); - } -} - -multi sub abs($x) { $x.abs() } -multi sub exp($x) { $x.Num.exp() } -multi sub log($x) { $x.log() } -multi sub log($x, $base) { $x.log($base) } -multi sub log10($x) { $x.log10 } - -# jnthn says that we should have both the multi sub declaration and the proto. - -multi sub sin($x, $base = 'radians') { - $x.sin($base) -} - -proto sin($x, $base = 'radians') { - sin($x, $base) -} - -multi sub asin($x, $base = 'radians') { - $x.asin($base) -} - -proto asin($x, $base = 'radians') { - asin($x, $base) -} - -multi sub cos($x, $base = 'radians') { - $x.cos($base) -} - -proto cos($x, $base = 'radians') { - cos($x, $base) -} - -multi sub acos($x, $base = 'radians') { - $x.acos($base) -} - -proto acos($x, $base = 'radians') { - acos($x, $base) -} - -multi sub tan($x, $base = 'radians') { - $x.tan($base) -} - -proto tan($x, $base = 'radians') { - tan($x, $base) -} - -multi sub atan($x, $base = 'radians') { - $x.atan($base) -} - -proto atan($x, $base = 'radians') { - atan($x, $base) -} - -multi sub sec($x, $base = 'radians') { - $x.sec($base) -} - -proto sec($x, $base = 'radians') { - sec($x, $base) -} - -multi sub asec($x, $base = 'radians') { - $x.asec($base) -} - -proto asec($x, $base = 'radians') { - asec($x, $base) -} - -multi sub cosec($x, $base = 'radians') { - $x.cosec($base) -} - -proto cosec($x, $base = 'radians') { - cosec($x, $base) -} - -multi sub acosec($x, $base = 'radians') { - $x.acosec($base) -} - -proto acosec($x, $base = 'radians') { - acosec($x, $base) -} - -multi sub cotan($x, $base = 'radians') { - $x.cotan($base) -} - -proto cotan($x, $base = 'radians') { - cotan($x, $base) -} - -multi sub acotan($x, $base = 'radians') { - $x.acotan($base) -} - -proto acotan($x, $base = 'radians') { - acotan($x, $base) -} - -multi sub sinh($x, $base = 'radians') { - $x.sinh($base) -} - -proto sinh($x, $base = 'radians') { - sinh($x, $base) -} - -multi sub asinh($x, $base = 'radians') { - $x.asinh($base) -} - -proto asinh($x, $base = 'radians') { - asinh($x, $base) -} - -multi sub cosh($x, $base = 'radians') { - $x.cosh($base) -} - -proto cosh($x, $base = 'radians') { - cosh($x, $base) -} - -multi sub acosh($x, $base = 'radians') { - $x.acosh($base) -} - -proto acosh($x, $base = 'radians') { - acosh($x, $base) -} - -multi sub tanh($x, $base = 'radians') { - $x.tanh($base) -} - -proto tanh($x, $base = 'radians') { - tanh($x, $base) -} - -multi sub atanh($x, $base = 'radians') { - $x.atanh($base) -} - -proto atanh($x, $base = 'radians') { - atanh($x, $base) -} - -multi sub sech($x, $base = 'radians') { - $x.sech($base) -} - -proto sech($x, $base = 'radians') { - sech($x, $base) -} - -multi sub asech($x, $base = 'radians') { - $x.asech($base) -} - -proto asech($x, $base = 'radians') { - asech($x, $base) -} - -multi sub cosech($x, $base = 'radians') { - $x.cosech($base) -} - -proto cosech($x, $base = 'radians') { - cosech($x, $base) -} - -multi sub acosech($x, $base = 'radians') { - $x.acosech($base) -} - -proto acosech($x, $base = 'radians') { - acosech($x, $base) -} - -multi sub cotanh($x, $base = 'radians') { - $x.cotanh($base) -} - -proto cotanh($x, $base = 'radians') { - cotanh($x, $base) -} - -multi sub acotanh($x, $base = 'radians') { - $x.acotanh($base) -} - -proto acotanh($x, $base = 'radians') { - acotanh($x, $base) -} - -multi sub atan2($y, $x = 1, $base = 'radians') { - $y.atan2($x, $base) -} - -proto atan2($y, $x = 1, $base = 'radians') { - atan2($y, $x, $base) -} - -our Num sub rand (*@args) { - die "too many arguments passed - 0 params expected" if @args; - 1.rand -} - -multi sub sqrt(Any $x) { - $x.Num.sqrt -} - -proto sign($x) { - defined($x) ?? $x.Num.sign !! Bool; -} - -multi sub roots($x, $n) { - $x.Complex.roots($n) -} - -# vim: ft=perl6 diff --git a/src/old/setting/Any-str.pm b/src/old/setting/Any-str.pm deleted file mode 100644 index ac1d6e57e47..00000000000 --- a/src/old/setting/Any-str.pm +++ /dev/null @@ -1,245 +0,0 @@ -class Any is also { - our Int multi method bytes() is export { - Q:PIR { - $S0 = self - $I0 = bytelength $S0 - %r = box $I0 - } - } - - our Str multi method capitalize() is export { - self.lc.subst(/\w+/, { .ucfirst }, :global) - } - - our Str multi method chop() is export { - self.substr(0, -1) - } - - our Str multi method fmt(Str $format = '%s') { - sprintf($format, self) - } - - our Str multi method lc() is export { - Q:PIR { - $S0 = self - downcase $S0 - %r = 'prefix:~'($S0) - } - } - - our Str multi method lcfirst() is export { - self gt '' ?? self.substr(0,1).lc ~ self.substr(1) !! "" - } - - our Int multi method ord() is export { - fail('Can not take ord of empty string') if self.chars == 0; - Q:PIR { - $S0 = self - $I0 = ord $S0 - %r = box $I0 - } - } - - our Int multi method p5chomp() is export { - my $num = 0; - - for @.list -> $str is rw { - if $str ~~ /\x0a$/ { - $str = $str.substr(0, $str.chars - 1); - $num++; - } - } - - $num; - } - - # TODO: Return type should be a Char once that is supported. - our Str multi method p5chop() is export { - my $char = ''; - - for @.list -> $str is rw { - if $str gt '' { - $char = $str.substr($str.chars - 1, 1); - $str = $str.chop; - } - } - - $char - } - - our Str multi method samecase(Str $pattern) is export { - my @pattern = $pattern.split(''); - [~] gather { - my $p = ""; - for (~self).split('') -> $s { - $p = @pattern.shift if @pattern; - given $p { - when /<.upper>/ { take $s.uc } - when /<.lower>/ { take $s.lc } - default { take $s } - } - } - } - } - -=begin item split - - our List multi Str::split ( Str $delimiter , Str $input = $+_, Int $limit = inf ) - our List multi Str::split ( Rule $delimiter = /\s+/, Str $input = $+_, Int $limit = inf ) - our List multi Str::split ( Str $input : Str $delimiter , Int $limit = inf ) - our List multi Str::split ( Str $input : Rule $delimiter , Int $limit = inf ) - -String delimiters must not be treated as rules but as constants. The -default is no longer S<' '> since that would be interpreted as a constant. -P5's C<< split('S< >') >> will translate to C<.words> or some such. Null trailing fields -are no longer trimmed by default. We might add some kind of :trim flag or -introduce a trimlist function of some sort. - -B partial implementation only - -=end item - - our List multi method split(Code $delimiter, $limit = *, :$all) { - my $s = ~self; - my $l = $limit ~~ Whatever ?? Inf !! $limit; - my $keep = ''; - return gather { - while $l > 1 && $s ~~ $delimiter { - take $keep ~ $s.substr(0, $/.from); - if $/.from == $/.to { - $keep = $s.substr($/.to, 1); - $s.=substr($/.to + 1); - } else { - $keep = ''; - $s.=substr($/.to) - } - $l--; - next if $l < 1; - if $all { - $l--; - take $/; - } - } - take $keep ~ $s if $l > 0; - } - } - - multi method flip() is export { - (~self).split('').reverse().join; - } - - # TODO: substitute with '$delimiter as Str' once coercion is implemented - our List multi method split($delimiter, $limit = *) { - my Int $prev = 0; - my $l = $limit ~~ Whatever ?? Inf !! $limit; - my $s = ~self; - if $delimiter eq '' { - return gather { - take $s.substr($_, 1) for 0 .. ($s.chars - 1 min $l - 2); - if $l <= $s.chars { - take $s.substr($l - 1 ); - }; - } - } - return gather { - my $pos = 0; - while $l > 1 - && $pos < $s.chars - && defined ($pos = $s.index($delimiter, $prev)) { - take $s.substr($prev, $pos - $prev); - $prev = [max] 1 + $prev, $pos + (~$delimiter).chars; - $l--; - } - take $s.substr($prev) if $l > 0; - } - } - - our List multi method comb (Regex $matcher = /./, $limit = *) { - my $l = $limit ~~ Whatever ?? Inf !! $limit; - # currently we use a copy of self and destroy it piece by piece. - # the preferred way of doing it is using self, not destroying it, - # and use the :pos modifier to the regex. That way the offsets into - # self will be right - my $s = ~self; - return gather { - while $l > 0 && $s ~~ $matcher { - # if we have captures, return the actual match object - take @($/) || %($/) ?? $/.clone !! ~$/; - $l--; - $s.=substr([max] 1, $/.to); - } - } - } - - our List multi method words($limit = *) { - self.comb(/\S+/, $limit); - } - - # TODO: signature not fully specced in S32 yet - our Str multi method trim() is export { - (~self).subst(/(^\s+)|(\s+$)/, "", :g) - } - - our Str multi method uc() is export { - Q:PIR { - $S0 = self - upcase $S0 - %r = 'prefix:~'($S0) - } - } - - our Str multi method ucfirst() is export { - self gt '' ?? self.substr(0,1).uc ~ self.substr(1) !! "" - } - - our multi method eval() { - eval(~self); - } -} - -multi sub split($delimiter, $target, $limit = *, :$all) { - $target.split($delimiter, $limit, :$all); -} - -# TODO: '$filename as Str' once support for that is in place -multi sub lines(Str $filename, - :$bin = False, - :$enc = 'Unicode', - :$nl = "\n", - :$chomp = True) { - - my $filehandle = open($filename, :r); - return lines($filehandle, :$bin, :$enc, :$nl, :$chomp); -} - -sub unpack($template, $target) { - $template.trans(/\s+/ => '') ~~ / ((<[Ax]>)(\d+))* / - or return (); # unknown syntax - my $pos = 0; - return gather for $0.values -> $chunk { - my ($operation, $count) = $chunk.[0, 1]; - given $chunk.[0] { - when 'A' { take $target.substr($pos, $count); } - when 'x' { } # just skip - } - $pos += $count; - } -} - -multi sub infix:($str, $n) { - Q:PIR { - $P1 = find_lex '$n' - $I0 = $P1 - if $I0 > 0 goto do_repeat - $S0 = '' - goto done - do_repeat: - $P0 = find_lex '$str' - $S0 = $P0 - $S0 = repeat $S0, $I0 - done: - %r = box $S0 - } -} - -# vim: ft=perl6 diff --git a/src/old/setting/Array.pm b/src/old/setting/Array.pm deleted file mode 100644 index 68f9c81b38f..00000000000 --- a/src/old/setting/Array.pm +++ /dev/null @@ -1,47 +0,0 @@ -# "is export" on Array does not work (it's Perl6Array internally) - -class Array is also { - multi method delete(@array is rw: *@indices) { - my @result; - for @indices -> $index { - my $i = $index >= 0 - ?? $index - !! * + $index; - @result.push(do { my $workaround = @array[$i] }); - undefine @array[$i]; - if $index == (@array - 1) | -1 { - @array.pop; - } - } - @array.pop while @array && !defined @array[* - 1]; - return @result; - } - - multi method splice(@array is rw: $offset is copy = 0, $size? is copy, *@values) { - my @spliced; - my @deleted; - - $offset += @array.elems if $offset < 0; - $offset = @array.elems min floor($offset); - $size = floor( $size // (@array - $offset) ); - $size += @array.end if $size < 0; - - @spliced.push(@array.shift) while (--$offset >= 0 && @array); - @deleted.push(@array.shift) while (--$size >= 0 && @array); - @spliced.push(@values) if @values; - @spliced.push(@array) if @array; - - @array = @spliced; - return @deleted; - } -} - -multi delete(@array is rw, *@indices) { - @array.delete(|@indices); -} - -multi splice(@array is rw, $offset?, $size?, *@values) { - @array.splice($offset,$size,@values); -} - -# vim: ft=perl6 diff --git a/src/old/setting/Attribute.pm b/src/old/setting/Attribute.pm deleted file mode 100644 index b0a57a126d4..00000000000 --- a/src/old/setting/Attribute.pm +++ /dev/null @@ -1,10 +0,0 @@ -class Attribute { - has $.name; - has $.type; - has $.build; - has $.accessor; - has $.rw; - method readonly() { !$!rw } -} - -# vim: ft=perl6 diff --git a/src/old/setting/Block.pm b/src/old/setting/Block.pm deleted file mode 100644 index 572523c879b..00000000000 --- a/src/old/setting/Block.pm +++ /dev/null @@ -1,53 +0,0 @@ -class Block is also { - -=begin item arity - -=end item - method arity() { - if $.signature -> $sig { - my $arity = 0; - for $sig.params -> $p { - $arity++ unless $p.slurpy || $p.optional; - } - $arity - } - else { - Q:PIR { - $P0 = find_lex 'self' - $P0 = descalarref $P0 - $P1 = inspect $P0, "pos_required" - $P2 = inspect $P0, "named_required" - %r = $P1 + $P2 - }; - } - } - -=begin item count - -=end item - method count() { - if $.signature -> $sig { - my $count = 0; - for $sig.params -> $p { - $count++ unless $p.slurpy; - } - $count - } - else { - Q:PIR { - $P0 = find_lex 'self' - $P0 = descalarref $P0 - $P1 = inspect $P0, "pos_required" - $P2 = inspect $P0, "pos_optional" - $P3 = $P1 + $P2 - $P1 = inspect $P0, "named_required" - $P2 = inspect $P0, "named_optional" - $P4 = $P1 + $P2 - %r = $P3 + $P4 - }; - } - } - -} - -# vim: ft=perl6 diff --git a/src/old/setting/Bool.pm b/src/old/setting/Bool.pm deleted file mode 100644 index f9f884721f0..00000000000 --- a/src/old/setting/Bool.pm +++ /dev/null @@ -1,28 +0,0 @@ -class Bool is also { - -=begin item ACCEPTS - -=end item - method ACCEPTS($topic) { - return self; - } - -=begin item perl - -=end item - method perl() { - return self ?? 'Bool::True' !! 'Bool::False'; - } - -=begin item pick - -Returns True or False - -=end item - method pick() { - return rand < 0.5 ?? Bool::True !! Bool::False; - } - -} - -# vim: ft=perl6 diff --git a/src/old/setting/Buf.pm b/src/old/setting/Buf.pm deleted file mode 100644 index fe8dea380a2..00000000000 --- a/src/old/setting/Buf.pm +++ /dev/null @@ -1,17 +0,0 @@ -class Buf does Positional { - has @!values; - - method new(*@values) { - self.bless(*, :values(@values)); - } - - method decode($encoding = 'UTF-8') { - return ""; - } - - method list() { - return @!values; - } -} - -# vim: ft=perl6 diff --git a/src/old/setting/Code.pm b/src/old/setting/Code.pm deleted file mode 100644 index 4b94df0e6f2..00000000000 --- a/src/old/setting/Code.pm +++ /dev/null @@ -1,12 +0,0 @@ -class Code is also { - -=begin item ACCEPTS - -=end item - method ACCEPTS(Object $topic) { - self.count == 0 ?? self() !! self($topic) - } - -} - -# vim: ft=perl6 diff --git a/src/old/setting/Complex.pm b/src/old/setting/Complex.pm deleted file mode 100644 index 8d11d7a7518..00000000000 --- a/src/old/setting/Complex.pm +++ /dev/null @@ -1,317 +0,0 @@ -class Complex { - has $.re; - has $.im; - - multi method new($re, $im) { - self.bless(*, :$re, :$im); - } - - multi method ACCEPTS(Complex $topic) { - ($topic.re ~~ $.re) && ($topic.im ~~ $.im); - } - multi method ACCEPTS($topic) { - ($topic.Num ~~ $.re) && ($.im == 0); - } - - multi method abs() { - ($!re * $!re + $!im * $!im).sqrt - } - - multi method Complex() { self } - - multi method perl() { - "Complex.new({$.re.perl}, {$.im.perl})"; - } - - multi method Str() { - "$.re + {$.im}i"; - } - - multi method exp() { - Complex.new($.re.Num.exp * $.im.Num.cos, $.re.Num.exp * $.im.Num.sin); - } - - multi method sin($base = 'radians') { - $.re.sin($base) * $.im.cosh($base) + ($.re.cos($base) * $.im.sinh($base))i; - } - - multi method asin($base = 'radians') { - (-1i * log((self)i + sqrt(1 - self * self)))!from-radians($base); - } - - multi method cos($base = 'radians') { - $.re.cos($base) * $.im.cosh($base) - ($.re.sin($base) * $.im.sinh($base))i; - } - - multi method acos($base = 'radians') { - (pi / 2)!from-radians($base) - self.asin($base); - } - - multi method tan($base = 'radians') { - self.sin($base) / self.cos($base); - } - - multi method atan($base = 'radians') { - ((log(1 - (self)i) - log(1 + (self)i))i / 2)!from-radians($base); - } - - multi method sec($base = 'radians') { - 1 / self.cos($base); - } - - multi method asec($base = 'radians') { - (1 / self).acos($base); - } - - multi method cosec($base = 'radians') { - 1 / self.sin($base); - } - - multi method acosec($base = 'radians') { - (1 / self).asin($base); - } - - multi method cotan($base = 'radians') { - self.cos($base) / self.sin($base); - } - - multi method acotan($base = 'radians') { - (1 / self).atan($base); - } - - multi method sinh($base = 'radians') { - -((1i * self).sin($base))i; - } - - multi method asinh($base = 'radians') { - (self + sqrt(1 + self * self)).log!from-radians($base); - } - - multi method cosh($base = 'radians') { - (1i * self).cos($base); - } - - multi method acosh($base = 'radians') { - (self + sqrt(self * self - 1)).log!from-radians($base); - } - - multi method tanh($base = 'radians') { - -((1i * self).tan($base))i; - } - - multi method atanh($base = 'radians') { - (((1 + self) / (1 - self)).log / 2)!from-radians($base); - } - - multi method sech($base = 'radians') { - 1 / self.cosh($base); - } - - multi method asech($base = 'radians') { - (1 / self).acosh($base); - } - - multi method cosech($base = 'radians') { - 1 / self.sinh($base); - } - - multi method acosech($base = 'radians') { - (1 / self).asinh($base); - } - - multi method cotanh($base = 'radians') { - 1 / self.tanh($base); - } - - multi method acotanh($base = 'radians') { - (1 / self).atanh($base); - } - - multi method log() { - Q:PIR { - $P0 = get_root_namespace ['parrot'; 'Complex' ] - $P0 = get_class $P0 - $P0 = $P0.'new'() - $N0 = self.'re'() - $P0[0] = $N0 - $N1 = self.'im'() - $P0[1] = $N1 - $P0 = $P0.'ln'() - $N0 = $P0[0] - $P2 = box $N0 - $N1 = $P0[1] - $P3 = box $N1 - $P1 = get_hll_global 'Complex' - $P1 = $P1.'new'($P2, $P3) - %r = $P1 - } - } - - multi method log($base) { - $.log / $base.log; - } - - multi method log10() { - $.log / 10.log; - } - - multi method polar() { - $.abs, atan2($.im, $.re); - } - - multi method roots($n is copy) { - my ($mag, $angle) = @.polar; - return NaN if $n < 1; - return self if $n == 1; - return NaN if $!re|$!im ~~ Inf|NaN|-Inf; - $n = $n.Int; - $mag **= 1/$n; - (^$n).map: { $mag.unpolar( ($angle + $_ * 2 * pi) / $n) }; - } - - multi method sign() { - fail('Cannot take the sign() of a Complex number'); - } - - multi method sqrt() { - Q:PIR { - $P0 = get_root_namespace ['parrot'; 'Complex' ] - $P0 = get_class $P0 - $P0 = $P0.'new'() - $N0 = self.'re'() - $P0[0] = $N0 - $N1 = self.'im'() - $P0[1] = $N1 - $P0 = $P0.'sqrt'() - $N0 = $P0[0] - $P2 = box $N0 - $N1 = $P0[1] - $P3 = box $N1 - $P1 = get_hll_global 'Complex' - $P1 = $P1.'new'($P2, $P3) - %r = $P1 - } - } - - multi method cosec($base = 'radians') { - 1.0 / self!to-radians($base).sin; - } - - multi method cosech($base = 'radians') { - 1.0 / self!to-radians($base).sinh; - } - - multi method acosec($base = 'radians') { - (1.0 / self).asin!to-radians($base); - } - - multi method cotan($base = 'radians') { - 1.0 / self!to-radians($base).tan; - } - - multi method cotanh($base = 'radians') { - 1.0 / self!to-radians($base).tanh; - } - - multi method acotan($base = 'radians') { - (1.0 / self).atan!to-radians($base); - } - - multi method acosech($base = 'radians') { - (1.0 / self).asinh!to-radians($base); - } - - multi method acotanh($base = 'radians') { - (1.0 / self).atanh!to-radians($base); - } - - multi method Num { - if $!im == 0 { - $!re; - } else { - fail "You can only coerce a Complex to Num if the imaginary part is zero" - } - } -} - -multi sub abs(Complex $x) { $x.abs } - -multi sub infix:<+>(Complex $a, Complex $b) { - Complex.new($a.re + $b.re, $a.im + $b.im); -} - -multi sub infix:<+>(Complex $a, $b) is default { - Complex.new($a.re + $b, $a.im); -} - -multi sub infix:<+>($a, Complex $b) { - $b + $a; -} - -multi sub infix:<->(Complex $a, $b) is default { - $a + (-$b); -} - -multi sub infix:<->($a, Complex $b) { - $a + (-$b); -} - -multi sub infix:<*>(Complex $a, Complex $b) { - Complex.new($a.re * $b.re - $a.im * $b.im, $a.im * $b.re + $a.re * $b.im); -# Complex.new($a.re * $a.re - $a.im * $b.im, $a.re * $b.im + $a.im * $b.re); -} - -multi sub infix:<*>(Complex $a, $b) is default { - Complex.new($a.re * $b, $a.im * $b); - -} - -multi sub infix:<*>($a, Complex $b) { - Complex.new($a * $b.re, $a * $b.im); -} - -multi sub infix:(Complex $a, Complex $b) { - my $d = $b.re * $b.re + $b.im * $b.im; - Complex.new(($a.re * $b.re + $a.im * $b.im) / $d, - ($a.im * $b.re - $a.re * $b.im) / $d); -} - -multi sub infix:(Complex $a, $b) is default { - $a * (1/$b); -} - -multi sub infix:($a, Complex $b) { - Complex.new($a, 0) / $b; -} - -multi sub postfix:($x) { - Complex.new(0, +$x); -} - -multi sub postfix:(Complex $z) { - Complex.new(-$z.im, $z.re); -} - -multi sub prefix:<->(Complex $a) { - Complex.new(-$a.re, -$a.im); -} - -multi sub infix:<**>(Complex $a, $b) is default { - ($a.log * $b).exp; -} - -multi sub infix:<**>($a, Complex $b) { - ($a.log * $b).exp; -} - -multi sub sign(Complex $x) { $x.sign } - -multi sub sqrt(Complex $x) { - $x.sqrt; -} - -multi sub exp(Complex $x) { - $x.exp() -} - -# vim: ft=perl6 diff --git a/src/old/setting/Hash.pm b/src/old/setting/Hash.pm deleted file mode 100644 index 2a17f797ea4..00000000000 --- a/src/old/setting/Hash.pm +++ /dev/null @@ -1,73 +0,0 @@ -class Hash is also { - - multi method ACCEPTS(Regex $topic) { - any(@.keys) ~~ $topic; - } - - multi method ACCEPTS(%topic) { - @.keys.sort eqv %topic.keys.sort; - } - - # the spec says Array, not Positional, so we can't use the @ sigil here - multi method ACCEPTS(Array $topic) { - # we can't simply write - # $.contains(any(@($topic))) - # because .contains doesn't autothread, so we have to do it manually: - for $topic.list { - return Bool::True if $.exists($_); - } - Bool::False; - } - - multi method ACCEPTS($topic) { - $.contains($topic) - } - - multi method invert () is export { - gather { - for @.pairs { - for @( .value ) -> $i { - take ($i => .key) - } - } - } - } - - multi method push (*@values) { - my $previous; - my $has_previous; - for @values -> $e { - if $has_previous { - self!push_construct($previous, $e); - $has_previous = 0; - } elsif $e ~~ Pair { - self!push_construct($e.key, $e.value); - } else { - $previous = $e; - $has_previous = 1; - } - } - if $has_previous { - warn "Trailing item in Hash.push"; - } - } - - # push a value onto a hash item, constructing an array if necessary - method !push_construct (Object $key, Object $value) { - if self.exists($key) { - if self.{$key} ~~ Array { - self.{$key}.push: $value; - } else { - self.{$key} = [ self.{$key}, $value]; - } - } else { - self.{$key} = $value; - } - } -} - -multi reverse(%hash) { - %hash.reverse; -} - -# vim: ft=perl6 diff --git a/src/old/setting/IO.pm b/src/old/setting/IO.pm deleted file mode 100644 index 602653bead8..00000000000 --- a/src/old/setting/IO.pm +++ /dev/null @@ -1,83 +0,0 @@ -class IO is also { - - multi method close() is export { - try { - ?$!PIO.close() - } - $! ?? fail($!) !! Bool::True - } - - multi method eof() is export { - ?$!PIO.eof(); - } - - multi method get() is export { - my $x = $!PIO.readline; - return if $.eof && $x eq ''; - $!ins++; - $x.chomp; - } - - multi method ins() { - $!ins; - } - - multi method lines($limit = *) { - my @result; - my $l = $limit ~~ Whatever ?? Inf !! $limit; - while !$.eof && $l-- > 0 { - push @result, $.get; - } - @result; - } - - multi method print(*@items) { - try { - for @items -> $item { - $!PIO.print(~$item); - } - } - $! ?? fail($!) !! Bool::True; - } - - multi method printf($format, *@args) { - self.print(sprintf($format, |@args)); - } - - multi method say(*@items) { - self.print(@items, "\n"); - } - - multi method slurp() { - $!PIO.readall(); - } - - multi method t() { - $!PIO.isatty; - } -} - -multi sub lines(IO $filehandle, - :$bin = False, - :$enc = 'Unicode', - :$nl = "\n", - :$chomp = True) { - - fail 'Binary mode not supported yet' if $bin; - fail 'Encodings not supported yet' if $enc ne 'Unicode'; - fail 'Fancy newlines not supported yet' if $nl ne "\n"; - fail 'Lack of chomp not supported yet' if !$chomp; - - $filehandle.lines(); -} - -multi sub print(Object *@items) { $*OUT.print(@items); } - -multi sub prompt($msg) { - print $msg; - $*IN.get; -} - -multi sub say(Object *@items) { $*OUT.say(@items); } - -# vim: ft=perl6 diff --git a/src/old/setting/IO/Socket.pm b/src/old/setting/IO/Socket.pm deleted file mode 100644 index 2373b4b4640..00000000000 --- a/src/old/setting/IO/Socket.pm +++ /dev/null @@ -1,34 +0,0 @@ -use v6; - -role IO::Socket { - has $!PIO; - has $!buffer = ''; - - method recv (Int $bufsize = Inf) { - fail('Socket not available') unless $!PIO; - my $received; - while $bufsize > $!buffer.bytes { - $received = $!PIO.recv(); - last unless $received.chars; - $!buffer ~= $received; - } - if $bufsize == Inf { - $received = $!buffer; - $!buffer = ''; - } else { - $received = $!buffer.substr(0, $bufsize); - $!buffer .= substr($bufsize); - } - return $received; - } - - method send (Str $string) { - fail("Not connected") unless $!PIO; - return $!PIO.send($string); - } - - method close () { - fail("Not connected!") unless $!PIO; - return $!PIO.close(); - } -} diff --git a/src/old/setting/IO/Socket/INET.pm b/src/old/setting/IO/Socket/INET.pm deleted file mode 100644 index b8c7c80d802..00000000000 --- a/src/old/setting/IO/Socket/INET.pm +++ /dev/null @@ -1,53 +0,0 @@ -class IO::Socket::INET does IO::Socket { - - method open (Str $hostname, Int $port) { - - Q:PIR { - .include "socket.pasm" - .local pmc sock - .local pmc address - .local string hostname - .local int port - .local string buf - .local int ret - - $P0 = find_lex "$hostname" - hostname = $P0 - - $P0 = find_lex "$port" - port = $P0 - - # Create the socket handle - sock = root_new ['parrot';'Socket'] - unless sock goto ERR - sock.'socket'(.PIO_PF_INET, .PIO_SOCK_STREAM, .PIO_PROTO_TCP) - - # Pack a sockaddr_in structure with IP and port - address = sock.'sockaddr'(hostname, port) - sock.'connect'(address) - setattribute self, '$!PIO', sock - ERR: - .return (0) - } - } - - method socket(Int $domain, Int $type, Int $protocol) { - my $PIO := Q:PIR {{ %r = root_new ['parrot';'Socket'] }}; - $PIO.socket($domain, $type, $protocol); - return IO::Socket::INET.new( :PIO($PIO) ); - } - - method bind($host, $port) { - $!PIO.bind($!PIO.sockaddr($host, $port)); - return self; - } - - method listen() { - $!PIO.listen(1); - return self; - } - - method accept() { - return $!PIO.accept(); - } -} diff --git a/src/old/setting/Int.pm b/src/old/setting/Int.pm deleted file mode 100644 index 832891ddd1f..00000000000 --- a/src/old/setting/Int.pm +++ /dev/null @@ -1,117 +0,0 @@ -class Int is also { - multi method abs() { - Q:PIR { - $I0 = self - $I0 = abs $I0 - %r = box $I0 - } - } - our Int multi method Int() { self } - - our Num multi method Num() { - Q:PIR { - $N0 = self - %r = box $N0 - } - } - - our Rat multi method Rat() { Rat.new(self, 1); } - - our Complex multi method Complex() { Complex.new(self, 0); } - - our Str multi method Str() { - ~self; - } - - # Most of the trig functions for Int are in Any-num.pm, but - # sec is a special case. - our Num multi method sec($base = 'radians') { - self.Num.sec($base); - } - - our Complex multi method unpolar($angle) is export { - Complex.new(self.Num * $angle.cos("radians"), self.Num * $angle.sin("radians")); - } - - our Int multi method sign() { - self.Num.sign - } -} - -multi sub abs(Int $x) { $x.abs } - -multi sub infix:<+>(Int $a, Int $b) { - Q:PIR { - $P0 = find_lex '$a' - $N0 = $P0 - $P1 = find_lex '$b' - $N1 = $P1 - $N2 = $N0 + $N1 - %r = '!upgrade_to_num_if_needed'($N2) - } -} - -multi sub infix:<->(Int $a, Int $b) { - Q:PIR { - $P0 = find_lex '$a' - $N0 = $P0 - $P1 = find_lex '$b' - $N1 = $P1 - $N2 = $N0 - $N1 - %r = '!upgrade_to_num_if_needed'($N2) - } -} - -multi sub infix:<*>(Int $a, Int $b) { - Q:PIR { - $P0 = find_lex '$a' - $N0 = $P0 - $P1 = find_lex '$b' - $N1 = $P1 - $N2 = $N0 * $N1 - %r = '!upgrade_to_num_if_needed'($N2) - } -} - -multi sub infix:
(Int $a, Int $b) { - Q:PIR { - $P0 = find_lex '$a' - $I0 = $P0 - $P1 = find_lex '$b' - $I1 = $P1 - $I2 = $I0 / $I1 - %r = box $I2 - } -} - -multi sub infix:<%>(Int $a, Int $b) { - Q:PIR { - $P0 = find_lex '$a' - $N0 = $P0 - $P1 = find_lex '$b' - $N1 = $P1 - $N2 = mod $N0, $N1 - %r = '!upgrade_to_num_if_needed'($N2) - } -} - -multi sub infix:<**>(Int $a, Int $b) { - Q:PIR { - $P0 = find_lex '$a' - $N0 = $P0 - $P1 = find_lex '$b' - $N1 = $P1 - $N2 = pow $N0, $N1 - %r = '!upgrade_to_num_if_needed'($N2) - } -} - -multi sub prefix:<->(Int $a) { - Q:PIR { - $P0 = find_lex '$a' - $N0 = $P0 - $N0 = neg $N0 - %r = '!upgrade_to_num_if_needed'($N0) - } -} - diff --git a/src/old/setting/Junction.pm b/src/old/setting/Junction.pm deleted file mode 100644 index 4bf86f0c95a..00000000000 --- a/src/old/setting/Junction.pm +++ /dev/null @@ -1,13 +0,0 @@ -class Junction is also { - our Str multi method Str() { - $.perl; - } - - method postcircumfix:<( )>(*@pos, *%named) { - my @result = $.eigenstates.map({ $^code(|@pos, |%named) }); - return Junction.new( - eigenstates => @result, - type => self!type - ); - } -} diff --git a/src/old/setting/List.pm b/src/old/setting/List.pm deleted file mode 100644 index 0bc5a557374..00000000000 --- a/src/old/setting/List.pm +++ /dev/null @@ -1,55 +0,0 @@ -class List is also { - -=begin item fmt - - our Str multi List::fmt ( Str $format = '%s', $separator = ' ' ) - -Returns the invocant list formatted by an implicit call to C on each -of the elements, then joined with spaces or an explicitly given separator. - -=end item - multi method fmt(Str $format = '%s', $sep = ' ') is export { - return join($sep, self.map({ sprintf($format, $^elem) })); - } - -=begin item iterator() - -Returns an iterator for the list. - -=end item - method iterator() { - return Q:PIR { - self.'!flatten'() - %r = iter self - }; - } - -=begin item list - -A List in list context returns itself. - -=end item - method list() { - return self; - } - -=begin item perl() - -Returns a Perl representation of a List. - -=end item - method perl() { - return '[' ~ self.map({ .perl }).join(", ") ~ ']'; - } - - method rotate(Int $n = 1) is export { - my Int $k = $n % $.elems; - self.[$k .. $.elems-1, 0 .. $k-1] - } - - method Capture(@self:) { - Capture.new(|@self) - } -} - -# vim: ft=perl6 diff --git a/src/old/setting/Mapping.pm b/src/old/setting/Mapping.pm deleted file mode 100644 index 65320dac961..00000000000 --- a/src/old/setting/Mapping.pm +++ /dev/null @@ -1,15 +0,0 @@ -class Mapping is also { -=begin item perl() - -Returns a Perl representation of a Mapping. - -=end item - method perl() { - return '{' ~ self.pairs.map({ .perl }).join(", ") ~ '}'; - } - - method Capture(%self:) { - Capture.new(|%self) - } -} - diff --git a/src/old/setting/Match.pm b/src/old/setting/Match.pm deleted file mode 100644 index a654bbd7b41..00000000000 --- a/src/old/setting/Match.pm +++ /dev/null @@ -1,96 +0,0 @@ -class Match is also { - multi method perl() { - self!_perl(0); - } - - my method _perl(Int $indent) { - return [~] gather { - my $sp = ' ' x ($indent + 1); - take "Match.new(\n"; - if $indent == 0 { - take " # WARNING: this is not working perl code\n"; - take " # and for debugging purposes only\n"; - } - take $sp; - take "ast => {$.ast.perl},\n"; - take $sp; - take "Str => {$.Str.perl},\n"; - take $sp; - take "from => $.from,\n"; - take $sp; - take "to => $.to,\n"; - if @(self) { - take $sp; - take "positional => [\n"; - # work around RT #64952 - for ^self.list { - take "$sp "; - self!_perl_quant(self.[$_], $indent); - take ",\n"; - } - take $sp; - take "],\n"; - } - if %(self) { - take $sp; - take "named => \{\n"; - for %(self).pairs { - take "$sp '{.key}' => "; - self!_perl_quant(.value, $indent); - take ",\n"; - } - take "$sp\},\n"; - } - take ' ' x $indent; - take ")"; - } - } - - method !_perl_quant($obj, $indent) { - my $sp = ' ' x $indent; - if !defined($obj) { - take '()'; - } elsif $obj ~~ Match { - take $obj!_perl($indent + 3); - } else { - take "[\n"; - for $obj.list { - take $sp ~ ' '; - take $_!_perl($indent + 5); - take ",\n"; - } - take "$sp ]"; - } - } - - multi method caps() { - my @caps = gather { - for self.list.pairs, self.hash.pairs -> $p { - # in regexes like [(.) ...]+, the capture for (.) is - # a List. flatten that. - if $p.value ~~ List { - take ($p.key => $_) for @($p.value); - } else { - take $p; - } - } - } - @caps.sort({ .value.from }); - } - - multi method chunks() { - my $prev = $.from; - gather { - for @.caps { - if .value.from > $prev { - take '~' => self.substr($prev - $.from, .value.from - $prev) - } - take $_; - $prev = .value.to; - } - take ('~' => self.substr($prev - $.from)) if $prev < $.to; - } - } -} - -# vim: ft=perl6 diff --git a/src/old/setting/NYI.pm b/src/old/setting/NYI.pm deleted file mode 100644 index 171175d97e0..00000000000 --- a/src/old/setting/NYI.pm +++ /dev/null @@ -1,32 +0,0 @@ -multi caller(){ - die 'caller() is not yet implemented in Rakudo, sorry'; -} -multi context(){ - die 'context() is not yet implemented in Rakudo, sorry'; -} -multi runinstead(){ - die 'runinstead() is not yet implemented in Rakudo, sorry'; -} - -multi cat($) { - die 'cat() and streams are not yet implemented in Rakudo, sorry'; -} - -multi infix:«==>» (*@a) { - die 'Feed operators are not yet implemented in Rakudo, sorry'; -} -multi infix:«<==» (*@a) { - die 'Feed operators are not yet implemented in Rakudo, sorry'; -} -multi infix:«==>>» (*@a) { - die 'Feed operators are not yet implemented in Rakudo, sorry'; -} -multi infix:«<<==» (*@a) { - die 'Feed operators are not yet implemented in Rakudo, sorry'; -} - -multi infix:($a, $b) { - die 'infix: not yet implemented in Rakudo, sorry'; -} - -# vim: ft=perl6 diff --git a/src/old/setting/Num.pm b/src/old/setting/Num.pm deleted file mode 100644 index 89fa54127cb..00000000000 --- a/src/old/setting/Num.pm +++ /dev/null @@ -1,370 +0,0 @@ -class Num is also { - multi method ACCEPTS($other) { - if self eq 'NaN' { - $other eq 'NaN'; - } else { - $other == self; - } - } - multi method ACCEPTS(Complex $other) { - if self eq 'NaN' { - $other.re eq 'NaN' || $other.im eq 'NaN'; - } else { - $other.im == 0 && $other.re == self; - } - } - multi method Complex() { - Complex.new(self, 0); - } - - our Num multi method exp() { - my $r = Q:PIR { - $N0 = self - $N1 = exp $N0 - %r = box $N1 - }; - } - - our Num multi method acos($base = 'radians') { - my $r = Q:PIR { - $N0 = self - $N1 = acos $N0 - %r = box $N1 - }; - $r!from-radians($base) - } - - our Num multi method acosh($base = 'radians') { - my $r = Q:PIR { - $N0 = self - $N1 = $N0 * $N0 - $N1 -= 1 - $N1 = sqrt $N1 - $N0 += $N1 - $N0 = ln $N0 - %r = box $N0 - }; - $r!from-radians($base) - } - - our Num multi method acosec($base = 'radians') { - my $r = Q:PIR { - $N0 = self - $N1 = 1 / $N0 - $N2 = asin $N1 - %r = box $N2 - }; - $r!from-radians($base) - } - - our Num multi method acosech($base = 'radians') { - # MUST: This is certainly wrong -- if nothing else, - # asinh also calls from-radians on its result. - # (Except it seems to be passing tests?) - asinh(1/+self)!from-radians($base) - } - - our Num multi method acotan($base = 'radians') { - my $r = Q:PIR { - $N0 = self - $N1 = 1 / $N0 - $N2 = atan $N1 - %r = box $N2 - }; - $r!from-radians($base) - } - - our Num multi method acotanh($base = 'radians') { - my $r = Q:PIR { - $N0 = self - $N1 = 1 + $N0 - $N2 = $N0 - 1 - $N3 = $N1 / $N2 - $N4 = ln $N3 - $N4 = $N4 / 2 - %r = box $N4 - }; - $r!from-radians($base) - } - - our Num multi method asec($base = 'radians') { - my $r = Q:PIR { - $N0 = self - $N1 = asec $N0 - %r = box $N1 - }; - $r!from-radians($base) - } - - our Num multi method asech($base = 'radians') { - my $r = Q:PIR { - $N0 = self - $N1 = neg $N0 - $N1 *= $N0 - $N1 += 1 - $N1 = sqrt $N1 - $N1 += 1 - $N1 /= $N0 - $N1 = ln $N1 - %r = box $N1 - }; - $r!from-radians($base) - } - - our Num multi method asin($base = 'radians') { - my $r = Q:PIR { - $N0 = self - $N1 = asin $N0 - %r = box $N1 - }; - $r!from-radians($base) - } - - our Num multi method asinh($base = 'radians') { - my $r = Q:PIR { - $N0 = self - $N1 = $N0 * $N0 - $N1 += 1 - $N1 = sqrt $N1 - $N0 += $N1 - $N0 = ln $N0 - %r = box $N0 - }; - $r!from-radians($base) - } - - our Num multi method atan($base = 'radians') { - my $r = Q:PIR { - $N0 = self - $N1 = atan $N0 - %r = box $N1 - }; - $r!from-radians($base) - } - - our Num multi method atan2(Num $x = 1, $base = 'radians') { - my $r = Q:PIR { - $N0 = self - $P1 = find_lex "$x" - $N1 = $P1 - $N2 = atan $N0, $N1 - %r = box $N2 - }; - $r!from-radians($base) - } - - our Num multi method atanh($base = 'radians') { - my $r = Q:PIR { - $N0 = self - $N1 = 1 - $N0 - $N0 += 1 - $N0 /= $N1 - $N0 = ln $N0 - $N0 /= 2 - %r = box $N0 - }; - $r!from-radians($base) - } - - our Num multi method cos($base = 'radians') { - my $x = self!to-radians($base); - Q:PIR { - $P0 = find_lex "$x" - $N0 = $P0 - $N1 = cos $N0 - %r = box $N1 - }; - } - - our Num multi method cosh($base = 'radians') { - my $x = self!to-radians($base); - Q:PIR { - $P0 = find_lex "$x" - $N0 = $P0 - $N1 = cosh $N0 - %r = box $N1 - }; - } - - our Num multi method cosec($base = 'radians') { - my $x = self!to-radians($base); - Q:PIR { - $P0 = find_lex "$x" - $N0 = $P0 - $N1 = sin $N0 - $N1 = 1 / $N1 - %r = box $N1 - }; - } - - our Num multi method cosech($base = 'radians') { - my $x = self!to-radians($base); - Q:PIR { - $P0 = find_lex "$x" - $N0 = $P0 - $N1 = sinh $N0 - $N1 = 1 / $N1 - %r = box $N1 - }; - } - - our Num multi method cotan($base = 'radians') { - my $x = self!to-radians($base); - Q:PIR { - $P0 = find_lex "$x" - $N0 = $P0 - $N1 = tan $N0 - $N1 = 1 / $N1 - %r = box $N1 - } - } - - our Num multi method cotanh($base = 'radians') { - my $x = self!to-radians($base); - Q:PIR { - $P0 = find_lex "$x" - $N0 = $P0 - $N1 = tanh $N0 - $N1 = 1 / $N1 - %r = box $N1 - } - } - - multi method log() { - Q:PIR { - $N0 = self - $N0 = ln $N0 - %r = box $N0 - } - } - - multi method log($base) { - $.log / $base.log; - } - - our method log10 { - Q:PIR { - $N0 = self - $N0 = log10 $N0 - %r = box $N0 - } - } - - our Str multi method perl() { - ~self - } - - sub _modf($num) { my $q = $num.Int; $num - $q, $q; } - - multi method Rat($epsilon = 1.0e-6) { - my $num = +self; - my $signum = $num < 0 ?? -1 !! 1; - $num = -$num if $signum == -1; - - # Find convergents of the continued fraction. - - my ($r, $q) = _modf($num); - my ($a, $b) = 1, $q; - my ($c, $d) = 0, 1; - - while $r != 0 && abs($num - ($b/$d)) > $epsilon { - ($r, $q) = _modf(1/$r); - - ($a, $b) = ($b, $q*$b + $a); - ($c, $d) = ($d, $q*$d + $c); - } - - # Note that this result has less error than any Rational with a - # smaller denominator but it is not (necessarily) the Rational - # with the smallest denominator that has less than $epsilon error. - # However, to find that Rational would take more processing. - - Rat.new($signum * $b, $d); - } - - our Num multi method sec($base = 'radians') { - my $x = self!to-radians($base); - Q:PIR { - $P0 = find_lex "$x" - $N0 = $P0 - $N1 = sec $N0 - %r = box $N1 - } - } - - our Num multi method sech($base = 'radians') { - my $x = self!to-radians($base); - Q:PIR { - $P0 = find_lex "$x" - $N0 = $P0 - $N1 = sech $N0 - %r = box $N1 - } - } - - our Num multi method sin($base = 'radians') { - my $x = self!to-radians($base); - Q:PIR { - $P0 = find_lex "$x" - $N0 = $P0 - $N1 = sin $N0 - %r = box $N1 - } - } - - our Num multi method sinh($base = 'radians') { - my $x = self!to-radians($base); - Q:PIR { - $P0 = find_lex "$x" - $N0 = $P0 - $N1 = sinh $N0 - %r = box $N1 - } - } - - multi method sign { - self ~~ NaN ?? NaN !! self <=> 0; - } - - multi method sqrt() { - Q:PIR { - $N0 = self - $N0 = sqrt $N0 - %r = box $N0 - } - } - - our Str multi method Str() { - ~self - } - - our Num multi method Num() { - self; - } - - our Num multi method tan($base = 'radians') { - my $x = self!to-radians($base); - Q:PIR { - $P0 = find_lex "$x" - $N0 = $P0 - $N1 = tan $N0 - %r = box $N1 - } - } - - our Num multi method tanh($base = 'radians') { - my $x = self!to-radians($base); - Q:PIR { - $P0 = find_lex "$x" - $N0 = $P0 - $N1 = tanh $N0 - %r = box $N1 - } - } - - our Complex multi method unpolar(Num $angle) is export { - Complex.new(self * $angle.cos("radians"), self * $angle.sin("radians")); - } -} - -# vim: ft=perl6 diff --git a/src/old/setting/Object.pm b/src/old/setting/Object.pm deleted file mode 100644 index eddda22cb6e..00000000000 --- a/src/old/setting/Object.pm +++ /dev/null @@ -1,96 +0,0 @@ -subset Matcher of Object where { .can('ACCEPTS') }; - -class Object is also { - multi method perl { - self.WHAT.substr(0, -2) ~ '.new()'; - } - - multi method notdef() { - ! $.defined; - } - - multi method eigenstates { - list(self) - } - - method WALK(:$name!, :$canonical, :$ascendant, :$descendant, :$preorder, :$breadth, - :$super, Matcher :$omit, Matcher :$include) { - # First, build list of classes in the order we'll need them. - my @classes; - if $super { - @classes = self.^parents(:local); - } else { - if $breadth { - my @search_list = self.WHAT; - while @search_list { - push @classes, @search_list.list(); - my @new_search_list; - for @search_list -> $current { - for $current.^parents(:local) -> $next { - unless any(@new_search_list <<===>> $next) { - push @new_search_list, $next; - } - } - } - @search_list = @new_search_list; - } - } elsif $ascendant | $preorder { - my sub build_ascendent(Object $class) { - unless any(@classes <<===>> $class) { - push @classes, $class; - for $class.^parents(:local) { - build_ascendent($^parent); - } - } - } - build_ascendent(self.WHAT); - } elsif $descendant { - my sub build_descendent(Object $class) { - unless any(@classes <<===>> $class) { - for $class.^parents(:local) { - build_descendent($^parent); - } - push @classes, $class; - } - } - build_descendent(self.WHAT); - } else { - # Canonical, the default (just whatever the meta-class says) with us - # on the start. - @classes = self.^parents(); - @classes.unshift(self.WHAT); - } - } - - # Now we have classes, build method list. - my @methods; - for @classes -> $class { - if (!$include || $include.ACCEPTS($class)) && (!$omit || !$omit.ACCEPTS($class)) { - for $class.^methods(:local) -> $method { - my $check_name = $method.?name; - if $check_name.defined && $check_name eq $name { - @methods.push($method); - } - } - } - } - - return @methods; - } - - method Capture() { - my %attrs; - my @mro = self, self.^parents; - for @mro -> $class { - for $class.^attributes() -> $attr { - if $attr.accessor { - my $name = substr($attr.name, 2); - %attrs{$name} //= self."$name"(); - } - } - } - Capture.new(|%attrs); - } -} - -# vim: ft=perl6 diff --git a/src/old/setting/Operators.pm b/src/old/setting/Operators.pm deleted file mode 100644 index de43f296c79..00000000000 --- a/src/old/setting/Operators.pm +++ /dev/null @@ -1,375 +0,0 @@ -# operators defined in the setting - -multi sub infix:<...> (@lhs, @rhs) { - if @rhs == 2 && @rhs[0] ~~ Code { - &infix:<...>(@lhs, @rhs[0], :limit(@rhs[1])); - } else { - die "don't know how to handle a right-hand side of" - ~ @rhs.perl - ~ "in series operator"; - } -} - -multi sub infix:<...>($lhs, @rhs) { - my @a = $lhs; - &infix:<...>(@a, @rhs); -} - -multi sub infix:<...>($lhs, Whatever $) { - die 'Sorry, lazy lists and infinite ranges are not yet implemented'; -} - -multi sub infix:<...>(@lhs, Whatever $) { - die 'Sorry, lazy lists and infinite ranges are not yet implemented'; -} - -multi sub infix:<...>($lhs, Code $generator) { - my @a = $lhs; - &infix:<...>(@a, $generator); -} - -multi sub infix:<...> (@lhs, Code $generator, :$limit) { - my $c = $generator.count; - if $c > @lhs { - fail 'the closure wants more parameters than given on the LHS'; - } - my @result = @lhs; - my @r; - my $argument-indexes; - # WhateverCode objects don't have a signature yet (RT #69362), - # and we can't simply use a try { ... } block because its result - # throws a "Null PMC access in get_bool()" when used in boolean context. - # we have to use an ugly special case here. - # and we can't even used !~~ for that (RT #69364) - if !$generator.^isa(WhateverCode) and any( $generator.signature.params>>.slurpy ) { - $argument-indexes = 0..*-1; - } else { - $argument-indexes = *-$c .. *-1; - } - - # XXX work around http://rt.perl.org/rt3/Ticket/Display.html?id=66824 - # this is a bit ugly.. since @a[1..1] returns a single item and not - # an array, |@result[$one-item-range] throws the error - # "argument doesn't array" - my $comp; - if defined($limit) { - $comp = @lhs[*-1] cmp $limit; - } - - while @r = $generator(|@(@result[$argument-indexes])) { - if (defined($limit)) { - if (@r[*-1] cmp $limit) == 0 { - @result.push: @r; - last; - } elsif (@r[*-1] cmp $limit) != $comp { - last; - } - } - - @result.push: @r; - } - @result; -} - -# the magic one that handles stuff like -# 'a' ... 'z' and 'z' ... 'a' -multi sub infix:<...>($lhs, $rhs where { !($_ ~~ Code|Whatever) }) { - gather { - take $lhs; - if ($lhs cmp $rhs) == 1 { - my $x = $lhs; - # since my $a = 'a'; $a-- gives - # "Decrement out of range" we can't easily - # decrement over our target, which is why the - # case of going backwards is slighly more complicated - # than going forward - while (--$x cmp $rhs) == 1 { - # need to make a fresh copy here because of RT #62178 - my $y = $x; - take $y; - } - take $x if ($x cmp $rhs) == 0; - } elsif ($lhs cmp $rhs) == -1 { - my $x = $lhs; - while (++$x cmp $rhs) <= 0 { - my $y = $x; - take $y; - } - } - } -} - -multi sub infix: (Num $a, Num $b) { $a === $b } -multi sub infix: (Str $a, Str $b) { $a === $b } -multi sub infix: (Code $a, Code $b) { $a === $b } -multi sub infix: (Bool $a, Bool $b) { $a === $b } -multi sub infix: (Rat $a, Rat $b) { - $a.numerator === $b.numerator && $a.denominator == $b.denominator -}; -multi sub infix: (Positional $a, Positional $b) { - return Bool::False unless $a.WHAT === $b.WHAT; - return Bool::False unless $a.elems == $b.elems; - for @($a) Z @($b) -> $x, $y { - return Bool::False unless $x eqv $y; - } - Bool::True -} - -multi sub infix:(Pair $a, Pair $b) { - $a.key eqv $b.key && $a.value eqv $b.value; -} - -multi sub infix:(Mapping $a, Mapping $b) { - return Bool::False if +$a != +$b; - for $a.kv -> $k, $v { - return Bool::False unless $b.exists($k); - return Bool::False unless $b.{$k} eqv $v; - } - return Bool::True; -} - -multi sub infix:(Failure $a, Failure $b) { - # do we have different values of undef yet? - # if so, how do I detect them? - Bool::True; -} - -multi sub infix: ($a, $b) { - return Bool::False unless $a.WHAT === $b.WHAT; - return Bool::True if $a === $b; - die "infix: is only implemented for certain special cases yet." - ~"\n You tried to compare two objects of type " ~ $a.WHAT.perl; -} - -multi sub infix:(@a, @b) { - (@a[0] min @b[0], @a[1] max @b[1]); -} - -multi sub infix:($a, $b) { - ~$a cmp ~$b; -} - -sub prefix:<[//]>(*@a) { - for @a -> $item { - $item // next; - return $item; - } - return (); -} - -sub prefix:<[||]>(*@a) { - for @a -> $item { - $item || next; - return $item; - } - return (); -} - -multi sub infix:($a, $b) { ! ($a % $b) } - - -multi sub infix:<+>($a, $b) { - Q:PIR { - $P0 = find_lex '$a' - $N0 = $P0 - $P1 = find_lex '$b' - $N1 = $P1 - $N2 = $N0 + $N1 - %r = box $N2 - } -} - -multi sub infix:<->($a, $b) { - Q:PIR { - $P0 = find_lex '$a' - $N0 = $P0 - $P1 = find_lex '$b' - $N1 = $P1 - $N2 = $N0 - $N1 - %r = box $N2 - } -} - -multi sub infix:<*>($a, $b) { - Q:PIR { - $P0 = find_lex '$a' - $N0 = $P0 - $P1 = find_lex '$b' - $N1 = $P1 - $N2 = $N0 * $N1 - %r = box $N2 - } -} - -multi sub infix:($a, $b) { - Q:PIR { - $P0 = find_lex '$a' - $N0 = $P0 - $P1 = find_lex '$b' - $N1 = $P1 - $N2 = $N0 / $N1 - %r = box $N2 - } -} - -multi sub infix:<%>($a, $b) { - Q:PIR { - $P0 = find_lex '$a' - $N0 = $P0 - $P1 = find_lex '$b' - $N1 = $P1 - $N2 = mod $N0, $N1 - %r = box $N2 - } -} - -multi sub infix:<**>($a, $b) { - Q:PIR { - $P0 = find_lex '$a' - $N0 = $P0 - $P1 = find_lex '$b' - $N1 = $P1 - $N2 = pow $N0, $N1 - %r = box $N2 - } -} - -multi sub prefix:<->($a) { - Q:PIR { - $P0 = find_lex '$a' - $N0 = $P0 - $N0 = neg $N0 - %r = box $N0 - } -} - - -multi sub prefix:<~>(Object $a) { - Q:PIR { - $P0 = find_lex '$a' - $S0 = $P0 - %r = new ['Str'] - assign %r, $S0 - } -} - - -multi sub prefix:<~>(Multi $a) { $a.name } - -multi sub infix:($a, $b) { !($a == $b) } -multi sub infix:($a, $b) { !($a == $b) } -multi sub infix:($a, $b) { !($a eq $b) } -multi sub infix:($a, $b) { !($a eq $b) } - -multi sub infix:<< < >>($a, $b) { - ? Q:PIR { - $P0 = find_lex '$a' - $N0 = $P0 - $P1 = find_lex '$b' - $N1 = $P1 - $I0 = islt $N0, $N1 - %r = box $I0 - } -} - -multi sub infix:<< > >>($a, $b) { - ? Q:PIR { - $P0 = find_lex '$a' - $N0 = $P0 - $P1 = find_lex '$b' - $N1 = $P1 - $I0 = isgt $N0, $N1 - %r = box $I0 - } -} - -multi sub infix:<< <= >>($a, $b) { - ? Q:PIR { - $P0 = find_lex '$a' - $N0 = $P0 - $P1 = find_lex '$b' - $N1 = $P1 - $I0 = isle $N0, $N1 - %r = box $I0 - } -} - -multi sub infix:<< >= >>($a, $b) { - ? Q:PIR { - $P0 = find_lex '$a' - $N0 = $P0 - $P1 = find_lex '$b' - $N1 = $P1 - $I0 = isge $N0, $N1 - %r = box $I0 - } -} - -multi sub infix:<< < >>(Whatever $a, $b) { - Q:PIR { - $P0 = find_lex '$a' - $P1 = find_lex '$b' - .tailcall 'WhateverCodeX'('infix:<', $P0, $P1) - } -} - -multi sub infix:<< < >>($a, Whatever $b) { - Q:PIR { - $P0 = find_lex '$a' - $P1 = find_lex '$b' - .tailcall 'WhateverCodeX'('infix:<', $P0, $P1) - } -} - -multi sub infix:<< > >>(Whatever $a, $b) { - Q:PIR { - $P0 = find_lex '$a' - $P1 = find_lex '$b' - .tailcall 'WhateverCodeX'('infix:>', $P0, $P1) - } -} - -multi sub infix:<< > >>($a, Whatever $b) { - Q:PIR { - $P0 = find_lex '$a' - $P1 = find_lex '$b' - .tailcall 'WhateverCodeX'('infix:>', $P0, $P1) - } -} - -multi sub infix:<< <= >>(Whatever $a, $b) { - Q:PIR { - $P0 = find_lex '$a' - $P1 = find_lex '$b' - .tailcall 'WhateverCodeX'('infix:<=', $P0, $P1) - } -} - -multi sub infix:<< <= >>($a, Whatever $b) { - Q:PIR { - $P0 = find_lex '$a' - $P1 = find_lex '$b' - .tailcall 'WhateverCodeX'('infix:<=', $P0, $P1) - } -} - -multi sub infix:<< >= >>(Whatever $a, $b) { - Q:PIR { - $P0 = find_lex '$a' - $P1 = find_lex '$b' - .tailcall 'WhateverCodeX'('infix:>=', $P0, $P1) - } -} - -multi sub infix:<< >= >>($a, Whatever $b) { - Q:PIR { - $P0 = find_lex '$a' - $P1 = find_lex '$b' - .tailcall 'WhateverCodeX'('infix:>=', $P0, $P1) - } -} - -multi sub infix:($a, $b) { - !($a === $b); -} -# vim: ft=perl6 diff --git a/src/old/setting/Pair.pm b/src/old/setting/Pair.pm deleted file mode 100644 index 27b7b929b21..00000000000 --- a/src/old/setting/Pair.pm +++ /dev/null @@ -1,71 +0,0 @@ -class Pair is also { - -=begin item ACCEPTS() - -Called from smartmatches '$_ ~~ X'. - -For C<$_ ~~ Mapping> tests if C<$_{X.key} ~~ X.value> - -Else it delegates to a method call '.:Xkey(Xval)' -(TODO: should actually be .Xkey, not .:Xkey). - -=end item - - multi method ACCEPTS(Mapping $topic) { - $topic{$.key} ~~ $.value; - } - - multi method ACCEPTS($topic) { - my $meth_name = ':' ~ $.key; - return $topic."$meth_name"($.value); - } - -=begin item fmt - - our Str multi Pair::fmt ( Str $format = "%s\t%s" ) - -Returns the invocant pair formatted by an implicit call to C on -the key and value. - -=end item - method fmt(Str $format = "%s\t%s") { - return sprintf($format, $.key, $.value); - } - -=begin item kv - -Return key and value as a 2-element List. - -=end item - method kv() { - return list($.key, $.value); - } - -=begin item pairs - -=end item - method pairs() { - return self.list(); - } - -=begin item value - -Gets the value of the pair. - -=end item - method value() { - return $!value; - } - -=begin item perl - -Returns a Perl code representation of the pair. - -=end item - method perl() { - return $.key.perl ~ ' => ' ~ $.value.perl; - } - -} - -# vim: ft=perl6 diff --git a/src/old/setting/Parameter.pm b/src/old/setting/Parameter.pm deleted file mode 100644 index 5166730e2ff..00000000000 --- a/src/old/setting/Parameter.pm +++ /dev/null @@ -1,27 +0,0 @@ -class Parameter { - multi method new(*%args) { - for -> $n { - # %args{$n}.=true doesn't seem to work here. - %args{$n} = ?%args{$n} if %args.exists($n); - } - self.bless(*, |%args); - } - has $.name; - has $.type; - has $.constraints; - has $.rw; - has $.ref; - has $.copy; - method readonly() { !$!rw && !$!ref && !$!copy } - has $.named; - has $.named_names; - has $.slurpy; - has $.optional; - has $.default; - has $.invocant; - has $.multi_invocant; - has $.type_captures; - has $.signature; -} - -# vim: ft=perl6 diff --git a/src/old/setting/Range.pm b/src/old/setting/Range.pm deleted file mode 100644 index b9634ad8ea6..00000000000 --- a/src/old/setting/Range.pm +++ /dev/null @@ -1,71 +0,0 @@ -class Range is also { - has $.by = 1; - has $.from; - has $.from_exclusive = Bool::False; - has $.to; - has $.to_exclusive = Bool::False; - - our Bool multi method ACCEPTS(Range $topic) { - ?(($.from == $topic.from) && ($.to == $topic.to) && - ($.from_exclusive == $topic.from_exclusive) && - ($.to_exclusive == $topic.from_exclusive) && - ($.by == $topic.by)) - } - - our Bool multi method ACCEPTS($topic) { - ?(self!from_test($topic) && self!to_test($topic)) - } - - our Range multi method iterator() { - $.clone - } - - multi method max() { - $.to - } - - multi method min() { - $.from - } - - multi method minmax() { - ($.from, $.to) - } - - # TODO: Add support for the :by(..) adverbial modifier. - our Str multi method perl() { - if $.by == 1 { - [~] - $.from.perl, - ("^" if $.from_exclusive), - "..", - ("^" if $.to_exclusive), - $.to.perl; - } else { - 'Range.new(' - ~ join(', ', - 'from => ' ~ $.from.perl, - 'to => ' ~ $.to.perl, - 'by => ' ~ $.by.perl, - 'from_exclusive => ' ~ $.from_exclusive.perl, - 'to_exclusive => ' ~ $.to_exclusive.perl, - ) - ~ ')' - } - } - - our #`(Range) multi method reverse() { - # XXX Should eventually return a reversed Range. - @.list.reverse; - } - - our #`(Bool) multi method true() { - # XXX For some reason, simply ?-ing what follows does not fix the - # return type to Bool. Needs investigating... - self!to_test($.from_exclusive ?? ++($.from.clone) !! $.from) - } - - our Str multi method Str() { - ~$.list - } -} diff --git a/src/old/setting/Rat.pm b/src/old/setting/Rat.pm deleted file mode 100644 index 4bee967efd2..00000000000 --- a/src/old/setting/Rat.pm +++ /dev/null @@ -1,117 +0,0 @@ -class Rat { - has $.numerator; - has $.denominator; - - # XXX TODO: should be lexical sub, but can't do those subs in setting yet. - sub gcd(Int $a is copy, Int $b is copy) { - $a = -$a if ($a < 0); - $b = -$b if ($b < 0); - while $a > 0 && $b > 0 { - ($a, $b) = ($b, $a) if ($b > $a); - $a %= $b; - } - return $a + $b; - } - - multi method new(Int $numerator is copy, Int $denominator is copy) { - if $denominator < 0 { - $numerator = -$numerator; - $denominator = -$denominator; - } - my $gcd = gcd($numerator, $denominator); - $numerator = $numerator div $gcd; - $denominator = $denominator div $gcd; - self.bless(*, :$numerator, :$denominator); - } - - multi method perl() { "$!numerator/$!denominator"; } - - multi method Num() { $!numerator.Num / $!denominator.Num } - - multi method Str() { $.Num.Str; } - - multi method nude() { $.numerator, $.denominator; } - - # Most of the trig functions for Rat are in Any-num.pm, but - # sec is a special case. - our Num multi method sec($base = 'radians') { - self.Num.sec($base); - } - - multi method succ { - Rat.new($!numerator + $!denominator, $!denominator); - } - multi method pred { - Rat.new($!numerator - $!denominator, $!denominator); - } - - multi method abs { - self < 0 ?? -self !! self; - } - - our Int multi method sign() { - self.Num.sign - } -} - -multi sub infix:<+>(Rat $a, Rat $b) { - my $gcd = Rat::gcd($a.denominator, $b.denominator); - ($a.numerator * ($b.denominator div $gcd) + $b.numerator * ($a.denominator div $gcd)) - / (($a.denominator div $gcd) * $b.denominator); -} - -multi sub infix:<+>(Rat $a, Int $b) { - ($a.numerator + $b * $a.denominator) / $a.denominator; -} - -multi sub infix:<+>(Int $a, Rat $b) { - ($a * $b.denominator + $b.numerator) / $b.denominator; -} - -multi sub infix:<->(Rat $a, Rat $b) { - my $gcd = Rat::gcd($a.denominator, $b.denominator); - ($a.numerator * ($b.denominator div $gcd) - $b.numerator * ($a.denominator div $gcd)) - / (($a.denominator div $gcd) * $b.denominator); -} - -multi sub infix:<->(Rat $a, Int $b) { - ($a.numerator - $b * $a.denominator) / $a.denominator; -} - -multi sub infix:<->(Int $a, Rat $b) { - ($a * $b.denominator - $b.numerator) / $b.denominator; -} - -multi sub prefix:<->(Rat $a) { - Rat.new(-$a.numerator, $a.denominator); -} - -multi sub infix:<*>(Rat $a, Rat $b) { - ($a.numerator * $b.numerator) / ($a.denominator * $b.denominator); -} - -multi sub infix:<*>(Rat $a, Int $b) { - ($a.numerator * $b) / $a.denominator; -} - -multi sub infix:<*>(Int $a, Rat $b) { - ($a * $b.numerator) / $b.denominator; -} - -multi sub infix:(Rat $a, Rat $b) { - ($a.numerator * $b.denominator) / ($a.denominator * $b.numerator); -} - -multi sub infix:(Rat $a, Int $b) { - $a.numerator / ($a.denominator * $b); -} - -multi sub infix:(Int $a, Rat $b) { - ($b.denominator * $a) / $b.numerator; -} - -multi sub infix:(Int $a, Int $b) { - Rat.new($a, $b); -} - -# vim: ft=perl6 sw=4 ts=4 expandtab diff --git a/src/old/setting/Signature.pm b/src/old/setting/Signature.pm deleted file mode 100644 index b7a88876686..00000000000 --- a/src/old/setting/Signature.pm +++ /dev/null @@ -1,77 +0,0 @@ -class Signature is also { - method perl() { - return [~] gather { - take ':('; - my $sep = ''; - my $last_was_multi_inv = True; - for $.params -> $param { - # First, separator, if any. - if $last_was_multi_inv && !$param.multi_invocant { $sep = ';; ' } - take ~$sep; - $sep = ', '; - - # First the type. - my $name = $param.name; - if !$param.slurpy { - my $sigil = substr($name, 0, 1); - my $perl = $param.type.perl; - if $sigil eq '$' { - take $perl ~ ' '; - } - elsif $sigil eq '@' { - if $perl ne 'Positional' { - take substr($perl, 11, $perl.chars - 12) ~ ' '; - } - } - elsif $sigil eq '%' { - if $perl ne 'Associative' { - take substr($perl, 12, $perl.chars - 13) ~ ' '; - } - } - elsif substr($perl, 0, 8) eq 'Callable' { - $name = '&' ~ $name; - if $perl ne 'Callable' { - take substr($perl, 9, $perl.chars - 10) ~ ' '; - } - } - else { - take $perl ~ ' '; - } - } - - # Any type captures. - for @($param.type_captures) -> $name { - take '::' ~ $name ~ ' '; - } - - # Slurpiness, namedness, then the name. - if $param.slurpy { take '*' } - for @($param.named_names) -> $name { - take ':' ~ $name ~ '('; - } - take $name; - take ')' x +$param.named_names; - - # Optionality. - if $param.optional && !$param.named && !$param.default { take '?' } - elsif !$param.optional && $param.named && !$param.slurpy { take '!' } - - # Any constraints? - my $cons_perl = $param.constraints.perl; - if $cons_perl ne 'Bool::True' { - take ' where ' ~ $cons_perl; - } - - # Default. - if $param.default { - take ' = ' ~ $param.default.perl; - } - - # Invocant/multi invocant marking. - if $param.invocant { $sep = ': '; } - $last_was_multi_inv = $param.multi_invocant; - } - take ')'; - } - } -} diff --git a/src/old/setting/Str.pm b/src/old/setting/Str.pm deleted file mode 100644 index f0d93df054a..00000000000 --- a/src/old/setting/Str.pm +++ /dev/null @@ -1,33 +0,0 @@ -class Str is also { - method Str() { self; } - - multi method encode($encoding = 'UTF-8', $nf = '') { - my @bytes = Q:PIR { - .local int bin_coding, i, max, byte - .local string bin_string - .local pmc it, result - $S0 = self - bin_coding = find_encoding 'fixed_8' - bin_string = trans_encoding $S0, bin_coding - result = new ['ResizablePMCArray'] - i = 0 - max = length bin_string - bytes_loop: - if i >= max goto bytes_done - byte = ord bin_string, i - push result, byte - inc i - goto bytes_loop - bytes_done: - %r = result - }; - return Buf.new(|@bytes); - } - - multi method Complex() { - # this is a really ugly hack for now - # we should properly parse self and also - # extract an imaginary part - (+self).Complex; - } -} diff --git a/src/old/setting/Temporal.pm b/src/old/setting/Temporal.pm deleted file mode 100644 index 5d23c35c89d..00000000000 --- a/src/old/setting/Temporal.pm +++ /dev/null @@ -1,183 +0,0 @@ -# Not Yet Implemented -#enum dayOfWeek ; -#enum DayOfWeek ; - -my subset Month of Int where { 1 <= $^a <= 12 }; -my subset Day of Int where { 1 <= $^a <= 31 }; -my subset DayOfWeek of Int where { 1 <= $^a <= 7 }; -my subset Hour of Int where { 0 <= $^a <= 23 }; -my subset Minute of Int where { 0 <= $^a <= 59 }; -my subset Second of Num where { 0 <= $^a <= 60 }; - -role Temporal::Date { - ## XXX Rakudo bug - can not use lexical subset types in a class yet - has Int $.year; - has #`(Month) $.month = 1; - has #`(Day) $.day = 1; - - method day-of-week { # returns DayOfWeek { - my ( $a, $y, $m, $jd ); # algorithm from Claus Tøndering - $a = (14 - $.month) div 12; - $y = $.year + 4800 - $a; - $m = $.month + 12 * $a - 3; - $jd = $.day + (153 * $m + 2) div 5 + 365 * $y + $y div 4 - - $y div 100 +$y div 400 - 32045; - return ($jd + 1) % 7 + 1; - } - - our Str method month-name { - return [$.month-1]; - } - - our Str method day-name { - return [self.day-of-week-1]; - } - - our Str method iso8601 { - given self { - return sprintf '%04d-%02d-%02d', .year, .month, .day; - } - } - - method Str { self.iso8601 }; - - sub infix:{'<=>'}( Temporal::Date $left, Temporal::Date $right ) - is export # would like to define it with «<=>» - { - $left.year <=> $right.year - || - $left.month <=> $right.month - || - $left.day <=> $right.day; - } - -} - -role Temporal::Time { - ## XXX Rakudo bug - can not use lexical subset types in a class yet - has #`(Hour) $.hour = 0; - has #`(Minute) $.minute = 0; - has #`(Second) $.second = 0; - - our Str method iso8601 { - given self { - return sprintf '%02d:%02d:%02d', .hour, .minute, .second; - } - } - - method Str { self.iso8601; } - - sub infix:{'<=>'}( Temporal::Time $left, Temporal::Time $right ) - is export # would like to define it with «<=>» - { - $left.hour <=> $right.hour - || - $left.minute <=> $right.minute - || - $left.second <=> $right.second; - } - -} - -role Temporal::TimeZone::Observance { - subset Offset of Int where { -86400 < $^a < 86400 }; - has Offset $.offset; - has Bool $.isdst; - has Str $.abbreviation; # UTC, CST, AST - - # The ISO8601 standard does not allow for offsets with sub-minute - # resolutions. In real-world practice, this is not an issue. - our Str method iso8601 { - sprintf "%+03d%02d", self.offset div 3600, - (abs(self.offset) div 60 ) % 60; - } - - method Str { self.iso8601 } -} - - -role Temporal::DateTime { - has Temporal::Date $.date; - has Temporal::Time $.time; - has Temporal::TimeZone::Observance $.timezone; - # TODO: replace the three above with the three below somehow fixed, - # and then revise the tests accordingly -# has Temporal::Date $!date handles ; -# has Temporal::Time $!time handles ; -# has Temporal::TimeZone::Observance $!timezone handles ; - - our Str method iso8601 { - self.date.iso8601 ~ 'T' ~ self.time.iso8601 ~ self.timezone.iso8601; - } - - method Str { self.iso8601 } - - # This involves a whole bunch of code - see Perl 5's Time::Local - our Num method epoch { - my ( $a, $y, $m, $jd ); # algorithm from Claus Tøndering - $jd = $.date.day + floor((153 * $m + 2) / 5) + 365 * $y - + floor( $y / 4 ) - floor( $y / 100 ) + floor( $y / 400 ) - 32045; - $a = (14 - $.date.month) div 12; - $y = $.date.year + 4800 - $a; - $m = $.date.month + 12 * $a - 3; - $jd = $.date.day + (153 * $m + 2) div 5 + 365 * $y - + $y div 4 - $y div 100 + $y div 400 - 32045; - return ($jd - 2440588) * 24 * 60 * 60 - + ($.time.hour*60 + $.time.minute)*60 + $.time.second; - } - - method Int { self.epoch.truncate } - - method Num { self.epoch } -} - -class Time { - - our method gmtime( Num $epoch = time ) { - my ( $time, $second, $minute, $hour, $day, $month, $year ); - $time = floor( $epoch ); - $second = $time % 60; $time = $time div 60; - $minute = $time % 60; $time = $time div 60; - $hour = $time % 24; $time = $time div 24; - # Day month and leap year arithmetic, based on Gregorian day #. - # 2000-01-01 noon UTC == 2451558.0 Julian == 2451545.0 Gregorian - $time += 2440588; # because 2000-01-01 == Unix epoch day 10957 - my $a = $time + 32044; # date algorithm from Claus Tøndering - my $b = (4 * $a + 3) div 146097; # 146097 = days in 400 years - my $c = $a - ( 146097 * $b ) div 4; - my $d = (4 * $c + 3) div 1461; # 1461 = days in 4 years - my $e = $c - ($d * 1461) div 4; - my $m = (5 * $e + 2) div 153; # 153 = days in Mar-Jul Aug-Dec - $day = $e - (153 * $m + 2) div 5 + 1; - $month = $m + 3 - 12 * ( $m div 10 ); - $year = $b * 100 + $d - 4800 + $m div 10; - Temporal::DateTime.new( - date => Temporal::Date.new(:$year, :$month, :$day), - time => Temporal::Time.new(:$hour, :$minute, :$second), - timezone => Temporal::TimeZone::Observance.new( - offset=>0, isdst=>Bool::False, abbreviation=>'UTC' ) - ); - } -# Not clear what spec S32-Temporal really means here... -# multi sub localtime( :$time = time(), :$tz= ) is export { ... } # NYI -# multi sub localtime( Num $epoch = time() ) returns Temporal::DateTime { ... } # NYI -# our Num sub time() { ... } # NYI -} - -=begin pod - -=head1 SEE ALSO -Perl 6 spec . -Perl 5 perldoc L. - -The best yet seen explanation of calendars, by Claus Tøndering -L. -Similar algorithms at L -and L. - - -