Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Tree: bae3748c93
Fetching contributors…

Cannot retrieve contributors at this time

1547 lines (1366 sloc) 48.884 kB
# vim: ft=perl6 fdm=marker
my module CORE;
use MONKEY_TYPING;
# Note that a few of these functions are defined as themselves. That
# means that the true definitions are in the optimizer, and the subs
# are only used for non-primitivizable cases.
# Fundamental types {{{
my class Mu {
method head(Mu $self:) { @($self).head }
method flattens(\$self:) {
Q:CgOp { (box Bool (var_islist {$self})) }
}
method typename(Mu $self:) { # should be ^name
Q:CgOp { (box Str (obj_typename (@ {$self}))) }
}
method Str(Mu $self:) {
my $tn := Q:CgOp { (box Str (obj_typename (@ {$self}))) };
if defined($self) {
$tn ~ "()<instance>"
} else {
$tn ~ "()"
}
}
method succ(Mu $self:) { defined($self) ?? die("cannot increment a value of type $self.typename()") !! 1 }
method pred(Mu $self:) { defined($self) ?? die("cannot decrement a value of type $self.typename()") !! -1 }
method notdef(Mu $self:) { !defined($self) }
method ACCEPTS(Mu $self: \$x) { defined($self) ?? $self === $x !! $x.^does($self) }
method perl(Mu $self:) { defined($self) ?? "{$self.typename}.new(...)" !! $self.typename }
method so(Mu $self:) { ?$self }
method not(Mu $self:) { !$self }
method CREATE(Mu $self: *%_) { Q:CgOp { (default_new (@ {$self}) (unbox varhash (@ {%_}))) } }
method new(Mu $self: *%_) { Q:CgOp { (default_new (@ {$self}) (unbox varhash (@ {%_}))) } }
}
my class Any is Mu {
method flat() { @(self) }
method Numeric() {
die "Cannot use value like $.typename as a number" if defined(self);
0;
}
method sort($cmp = &infix:<leg>) { @(self).sort($cmp) }
method first(Mu $filter) { for @(self) { return $_ if $_ ~~ $filter } }
method !butWHENCE($cr) {
Q:CgOp { (newvsubvar (class_ref mo Any) (@ {$cr}) (@ {self})) }
}
method hash() { anon %hash = @(self) }
}
my class Cursor { ... }
my class Regex { ... }
my class Num { ... }
my class Str { ... }
my class Cool {
method Rat($eps = 1e-6) { Q:CgOp { (bif_rat_approx {self} {$eps}) } }
method Int() { Q:CgOp { (bif_coerce_to_int {self}) } }
method Num() { Q:CgOp { (bif_coerce_to_num {self}) } }
method abs() { abs self }
method sqrt() { sqrt self }
method grep(Mu $sm) { grep $sm, @(self) }
method map($func) { map $func, @(self) }
method for (&cb) {
Q:CgOp {
(rnull (letn it (unbox vvarlist (@ {self.iterator}))
cb (@ {&cb})
(whileloop 0 0 (iter_hasflat (l it))
(sink (subcall (l cb) (vvarlist_shift (l it)))))))
};
}
method split($matcher, $limit = 1_000_000_000, :$all?) {
my $matchrx = (($matcher ~~ Regex) ?? $matcher !! /$matcher/);
my $str = ~self;
my $C = Cursor.new($str);
my @out;
my $i = 0;
my $last = 0;
my $limctr = $limit;
my $M;
while ($i <= chars $str) && ($limctr > 1) {
$M = head($matchrx($C.cursor($i++)));
if $M {
push @out, substr($str, $last, ($M.from - $last));
push @out, $M if $all;
$i = $i max ($last = $M.to);
$limctr = ($limctr - 1);
}
}
push @out, substr($str, $last, (chars($str) - $last));
@out;
}
method subst($matcher_, $replacement, :g(:$global)) {
my $str = ~self;
my $C = Cursor.new($str);
my $matcher = $matcher_ ~~ Regex ?? $matcher_ !! /$matcher_/;
my $i = 0;
my $to = 0;
my $limctr = $global ?? Inf !! 1;
my @out;
while $i < chars($str) && $limctr {
my $M = head($matcher($C.cursor($i++)));
if $M && $M.chars {
Q:CgOp { (rnull (set_status (s '$*/') {$M})) };
push @out, substr($str,$to,$M.from-$to);
push @out, ($replacement ~~ Str ?? $replacement !! $replacement());
$to = $i = $M.to;
$limctr = $limctr - 1;
}
}
join "", @out, substr($str,$to,chars($str)-$to);
}
method index($substring, $pos = 0) {
my $str = ~self;
my $fromc = $pos;
my $len = chars $substring;
my $maxi = chars($str) - $len;
while $fromc <= $maxi {
if substr($str,$fromc,$len) eq $substring {
return $fromc;
}
$fromc++;
}
Num; # XXX StrPos
}
method rindex($substring, $from?) {
my $str = ~self;
my $len = chars $substring;
my $fromc = (($from // 1_000_000_000) min (chars($str) - $len));
while $fromc >= 0 {
if substr($str,$fromc,$len) eq $substring {
return $fromc;
}
$fromc = $fromc - 1;
}
Num; # XXX StrPos
}
my $char = /./;
method comb($matcher = $char, $limit = 1_000_000_000, :$match) {
my $str = ~self;
my $C = Cursor.new($str);
my $i = 0;
my $limctr = $limit;
my @out;
while ($i < chars $str) && $limctr {
my $M = head($matcher($C.cursor($i++)));
if $M {
$i max= $M.to;
push @out, ($match ?? $M !! (~$M));
$limctr = $limctr - 1;
}
}
@out
}
method lines($limit = 1_000_000_000) {
self.comb(/ ^^ \N* /, $limit);
}
method words($limit = 1_000_000_000) {
self.comb(/ \S+ /, $limit);
}
method say() { (~self).say }
method chars() { chars(self) }
method bytes() { chars(self) * 2 }
method chomp() {
my $s = ~self;
my $l = chars($s);
--$l if $l && substr($s, $l-1, 1) eq "\x0A";
--$l if $l && substr($s, $l-1, 1) eq "\x0D";
substr($s,0,$l);
}
method chop() {
my $s = ~self;
substr($s, 0, chars($s) - 1)
}
method substr($x, $y = chars(self)-$x) { substr(self,$x,$y) }
method lc() { Q:CgOp { (box Str (str_tolower (obj_getstr {self}))) }}
method uc() { Q:CgOp { (box Str (str_toupper (obj_getstr {self}))) }}
method flip() { Q:CgOp { (box Str (str_flip (obj_getstr {self}))) }}
method ucfirst() { ucfirst(self) }
method lcfirst() { lcfirst(self) }
method at-pos(\$self: $ix) {
defined($self)
?? $self.list.at-pos($ix)
!! _vivify_array_at_pos($self, $ix)
}
method elems() { self.flat.elems }
method iterator() { self.flat.iterator }
method join($sep = "") { self.flat.join($sep) }
}
my class Capture {
has $!positionals;
has $!named;
method perl() {
self // return self.typename;
my $pos := Q:CgOp { (box Parcel (getslot positionals fvarlist (@ {self}))) }.perl;
$pos = substr($pos, 2, chars($pos) - 3);
$pos = substr($pos, 0, chars($pos) - 2) if substr($pos, chars($pos) - 2, 2) eq ', ';
my $h := self.hash;
if $h {
$pos ~= ", " if $pos ne "";
$pos ~= "|" ~ $h.perl;
}
'\(' ~ $pos ~ ')';
}
method Capture () { self }
method list () { @( Q:CgOp { (box Parcel (getslot positionals fvarlist
(@ {self}))) } ) }
method hash () { unitem( Q:CgOp {
(letn h (getslot named varhash (@ {self}))
(ternary (== (l h) (null varhash)) {{}} (box Hash (l h))))
}) }
}
# }}}
# Scalar types {{{
my class Num is Cool {
our constant pi = 3.14159_26535_89793_238e0;
our constant e = 2.71828_18284_59045_235e0;
our constant i = sqrt(-1);
method Num() { self }
method perl() { defined(self) ?? ~self !! self.typename }
method ACCEPTS(Mu $t) { defined(self) ?? self == $t !! $t.^does(self) }
}
our constant pi = 3.14159_26535_89793_238e0;
our constant e = 2.71828_18284_59045_235e0;
our constant i = sqrt(-1);
my class Int is Cool {
method Int() { self }
method perl() { defined(self) ?? ~self !! self.typename }
method ACCEPTS(Mu $t) { defined(self) ?? self == $t !! $t.^does(self) }
}
my class Rat is Cool {
method perl() { defined(self) ?? ~self !! self.typename }
method ACCEPTS(Mu $t) { defined(self) ?? self == $t !! $t.^does(self) }
}
my class Complex is Cool {
method perl() { defined(self) ?? ~self !! self.typename }
method ACCEPTS(Mu $t) { defined(self) ?? self == $t !! $t.^does(self) }
}
my class FatRat is Cool {
method perl() { defined(self) ?? ~self !! self.typename }
method ACCEPTS(Mu $t) { defined(self) ?? self == $t !! $t.^does(self) }
}
#TODO use a power from the standard library
sub infix:<**>($num,$power) {
my $ret = 1;
my $p = $power;
while ($p > 0) {
$ret *= $num;
$p--;
}
$ret;
}
my class Str is Cool {
method ACCEPTS(Mu $t) { defined(self) ?? self eq $t !! $t.^does(self) }
method chars() { chars(self) }
method say() { Q:CgOp {
(prog [say (unbox str (@ {self}))]
[box Bool (bool 1)]
)
} }
method Numeric() { Q:CgOp { (box Num (str_tonum (obj_getstr {self}))) } }
method substr($from, $len = chars(self)-$from) { substr(self, $from, $len) }
# XXX .trans
method perl() { defined(self) ?? '"' ~ self ~ '"' !! self.typename }
}
my class Scalar {
}
my class Sub {
has $!outer;
has $!info;
# Should be for Block, not Sub
method ACCEPTS(Mu $t) { defined(self) ?? (self)($t) !! $t.^does(self) }
method perl() { defined(self) ?? '{ ... }' !! self.typename }
}
my class ClassHOW {
method isa(Mu $obj, Mu $type) { Q:CgOp {
(box Bool (obj_isa (@ {$obj}) (obj_llhow (@ {$type}))))
} }
method does(Mu $obj, Mu $role) { self.isa($obj, $role) } #no roles yet
method can(Mu $obj, $name) { Q:CgOp {
(box Bool (_cgop obj_can (@ {$obj}) (obj_getstr {$name})))
} }
}
my class EnumType is Cool { }
my class Bool is EnumType {
method Str() { self ?? "Bool::True" !! "Bool::False" }
method Stringy() { self.key }
method perl() { defined(self) ?? ~self !! self.typename }
method ACCEPTS(Mu $t) { defined(self) ?? self !! $t.^does(self) }
method Numeric() { self ?? 1 !! 0 }
our constant True = Q:CgOp { (box Bool (bool 1)) };
our constant False = Q:CgOp { (box Bool (bool 0)) };
method succ() { True }
method pred() { False }
method key() { self ?? "True" !! "False" }
method value() { self ?? 1 !! 0 }
method kv() { self.key, self.value }
}
# TODO: import
constant True = Q:CgOp { (box Bool (bool 1)) };
constant False = Q:CgOp { (box Bool (bool 0)) };
# }}}
# Fundamental scalar operators {{{
sub infix:<~>(\|$bits) { Q:CgOp {
(letn buf (strbuf_new)
i (int 0)
ar (unbox fvarlist (@ {$bits}))
max (fvarlist_length (l ar))
[whileloop 0 0 (< (l i) (l max)) (prog
[strbuf_append (l buf)
(obj_getstr (fvarlist_item (l i) (l ar)))]
[l i (+ (l i) (int 1))])]
[box Str (strbuf_seal (l buf))])
} }
sub infix:<+>($l,$r) { $l + $r }
sub infix:<->($l,$r) { $l - $r }
sub infix:<*>($l,$r) { $l * $r }
sub infix:</>($l,$r) { $l / $r }
sub infix:<%>($l,$r) { $l % $r }
sub infix:<< < >>($l,$r) { $l < $r }
sub infix:<< > >>($l,$r) { $l > $r }
sub infix:<< <= >>($l,$r) { $l <= $r }
sub infix:<< >= >>($l,$r) { $l >= $r }
sub infix:<< == >>($l,$r) { $l == $r }
sub infix:<< != >>($l,$r) { $l != $r }
sub infix:<max>($a,$b) { $a < $b ?? $b !! $a }
sub infix:<min>($a,$b) { $a > $b ?? $b !! $a }
sub warn($str) { Q:CgOp {
(prog [note (obj_getstr {$str})]
[box Bool (bool 1)]
)
} }
sub say(*@text) { Q:CgOp { (rnull (say (obj_getstr {@text.join('')}))) }; True }
sub print(*@text) { Q:CgOp { (rnull (print (obj_getstr {@text.join('')}))) }; True }
sub note(*@text) { Q:CgOp { (rnull (note (obj_getstr {@text.join('')}))) }; True }
sub exit($status = 0) { Q:CgOp {
(rnull [exit (cast int (obj_getnum {$status}))])
} }
sub infix:<=>(\$a, \$b) { Q:CgOp { (prog [assign {$a} {$b}] {$a}) } }
sub chars($str) { chars($str) }
sub substr($str, $start, $len = chars($str) - $start) { substr($str, $start, $len) }
sub index($haystack,$needle) { $haystack.index($needle) }
sub item(Mu $x) { $x }
sub prefix:<not>($x) { not($x) }
sub defined(Mu $x) { defined($x) }
# Buglet in STD: standard infix operators look custom inside the setting, and
# forget their precedence.
sub prefix:<-->($v is rw) { $v = $v.pred; $v }
sub prefix:<++>($v is rw) { $v = $v.succ; $v }
sub postfix:<-->($v is rw) { my $old = $v; $v = $v.pred; $old }
sub postfix:<++>($v is rw) { my $old = $v; $v = $v.succ; $old }
sub prefix:<~>(Mu $v) { ~$v }
sub prefix:<?>(Mu $v) { ?$v }
sub prefix:<->(Mu $v) { -$v }
sub prefix:<+>(Mu $v) { +$v }
sub prefix:<!>(Mu $v) { !$v }
sub not(Mu $v) { not($v) }
sub infix:<x>($str, $ct) {
my $i = +$ct;
my $j = ''; # XXX use strbuf
while $i >= 1 {
$i--;
$j ~= $str;
}
$j;
}
sub infix:<leg>($s1, $s2) {
Q:CgOp { (box Num (cast num (strcmp (obj_getstr {$s1}) (obj_getstr {$s2})))) }
}
sub infix:<ge>($s1, $s2) { $s1 ge $s2 }
sub infix:<gt>($s1, $s2) { $s1 gt $s2 }
sub infix:<le>($s1, $s2) { $s1 le $s2 }
sub infix:<lt>($s1, $s2) { $s1 lt $s2 }
sub infix:<eq>($s1, $s2) { $s1 eq $s2 }
sub infix:<ne>($s1, $s2) { $s1 ne $s2 }
sub lc($string) { (~$string).lc }
sub uc($string) { (~$string).uc }
sub chop($string) { (~$string).chop }
sub chomp($string) { (~$string).chomp }
sub flip($string) { (~$string).flip }
sub lcfirst($o) { my $s = ~$o; lc(substr($s,0,1)) ~ substr($s,1) }
sub ucfirst($o) { my $s = ~$o; uc(substr($s,0,1)) ~ substr($s,1) }
# this one is horribly wrong and only handles the ref eq case.
sub infix:<===>($l,$r) { Q:CgOp {
(box Bool (compare == (@ {$l}) (@ {$r})))
} }
sub infix:<=:=>(\$l,\$r) { Q:CgOp {
(box Bool (compare == {$l} {$r}))
} }
sub _param_role_inst(\|$t) {
Q:CgOp { (instrole (unbox fvarlist (@ {$t}))) }
}
sub infix:<but>($obj, $role) { Q:CgOp {
(ns (stab_what (role_apply (obj_llhow (@ {$obj})) (obj_llhow (@ {$role})))))
} }
sub infix:<~~>($t,$m) { $m.ACCEPTS($t) }
sub ord($x) { Q:CgOp { (bif_ord {$x}) } }
sub chr($x) { Q:CgOp { (bif_chr {$x}) } }
sub infix:<+&>($x, $y) { Q:CgOp { (bif_numand {$x} {$y}) } }
sub infix:<+|>($x, $y) { Q:CgOp { (bif_numor {$x} {$y}) } }
sub infix:<+^>($x, $y) { Q:CgOp { (bif_numxor {$x} {$y}) } }
sub infix:<< +< >>($x, $y) { Q:CgOp { (bif_numlshift {$x} {$y}) } }
sub infix:<< +> >>($x, $y) { Q:CgOp { (bif_numrshift {$x} {$y}) } }
sub prefix:<< +^ >>($x) { Q:CgOp { (bif_numcompl {$x}) } }
# }}}
# Flow inspection and control {{{
my class CallFrame {
method caller() { Q:CgOp {
(letn c (frame_caller (cast frame (@ {self})))
(ternary
(!= (l c) (null frame))
(ns (l c))
{Any}))
} }
method file() { Q:CgOp { (box Str (frame_file
(cast frame (@ {self})))) } }
method line() { Q:CgOp { (box Num (cast num (frame_line
(cast frame (@ {self}))))) } }
method hints($var) { Q:CgOp { (frame_hint (cast frame (@ {self}))
(obj_getstr {$var})) } }
}
sub caller() { Q:CgOp { (ns (frame_caller (frame_caller (callframe)))) } }
sub callframe() { Q:CgOp { (ns (frame_caller (callframe))) } }
sub die($msg) { Q:CgOp { (die (@ {$msg})) } }
my class Label {
has $!target;
has $!name;
method goto() { _lexotic(8, self, ()) }
method next(\|@pcl) { _lexotic(1, self, @pcl.unwrap-single) }
method last(\|@pcl) { _lexotic(2, self, @pcl.unwrap-single) }
method redo(\|@pcl) { _lexotic(3, self, @pcl.unwrap-single) }
}
# XXX multi dispatch
sub _lexotic ($id, $x, Mu $val) {
Q:CgOp {
(letn fr (null frame)
nm (null str)
id (@ {$x})
(ternary (obj_isa (l id) (class_ref mo Label))
(prog (l fr (getslot target frame (l id)))
(l nm (getslot name str (l id))))
(ternary (obj_isa (l id) (class_ref mo Str))
(l nm (obj_getstr {$x}))
(prog)))
(control (cast int (obj_getnum {$id})) (l fr) (int -1) (l nm) {$val}))
}
}
sub next ($x?) { _lexotic(1, $x, ()) }
sub last ($x?) { _lexotic(2, $x, ()) }
sub redo ($x?) { _lexotic(3, $x, ()) }
sub goto ($x) { _lexotic(8, $x, ()) }
sub return(\|@pcl) is return-pass { Q:CgOp {
(control 4 (null frame) (int -1) (null str) {@pcl.unwrap-single})
} }
sub succeed() {
Q:CgOp { (control 6 (null frame) (int -1) (null str) {()}) }
}
sub proceed() {
Q:CgOp { (control 7 (null frame) (int -1) (null str) {()}) }
}
sub nextsame() {
Q:CgOp { (control 9 (null frame) (int -1) (null str) (null obj)) }
}
sub nextwith(|$cap) {
Q:CgOp { (control 9 (null frame) (int -1) (null str) (@ {$cap})) }
}
sub callsame () { Q:CgOp { (callnext (null obj)) } }
sub callwith (|$cap) { Q:CgOp { (callnext (@ {$cap})) } }
sub assignop($fn) {
anon sub _assign(\$lhs, \$rhs) {
$lhs = $fn($lhs, $rhs)
}
}
sub notop(&fn) { -> \$x, \$y { !(fn($x,$y)) } }
# }}}
# Aggregate types {{{
# Parcel: immutable list of boxes which have no context - may flatten, may
# autovivify, don't rebind or push/shift/etc
# List: mutable list of boxes without much context. accessing off end returns
# undefined. lazy.
# coercion makes the elements of a List read-only and maybe fetches them too.
# Array: mutable list of read-write scalar boxes
sub unitem(\$a) { Q:CgOp { (newrwlistvar (@ {$a})) } }
sub head(\$x) { for $x -> Mu $elt { return $elt }; Any }
my class Iterator {
method list () {
Q:CgOp {
(letn n (obj_newblank (class_ref mo List))
(iter_to_list (l n) (unbox vvarlist (@ {self})))
(newrwlistvar (l n)))
}
}
method flat () {
Q:CgOp {
(letn n (obj_newblank (class_ref mo List))
(iter_to_list (l n) (iter_flatten (unbox vvarlist (@ {self}))))
(newrwlistvar (l n)))
}
}
}
my class IterCursor {
# subclasses must provide .reify, return parcel
}
sub flat(*@x) { @x }
sub hash(\|@x) { %(@x.unwrap-single) }
my class Whatever {
method ACCEPTS(Mu $x) { defined(self) || $x.^isa(Whatever) }
}
my class EMPTY { }
my class List { ... }
my class Array { ... }
my class Parcel is Cool {
method flat() { self.iterator.flat }
method elems() { Q:CgOp {
(box Num (cast num (fvarlist_length (unbox fvarlist (@ {self})))))
} }
method unwrap-single(@self:) { Q:CgOp {
(letn p (unbox fvarlist (@ {@self}))
(ternary (== (i 1) (fvarlist_length (l p)))
(fvarlist_item (i 0) (l p)) {@self}))
} }
method Capture () {
Q:CgOp {
(letn n (obj_newblank (obj_llhow (@ {Capture})))
(setslot positionals (l n) (unbox fvarlist (@ {self})))
(ns (l n)))
}
}
method perl(\$self:) {
$self // return $self.typename;
my @tok;
@tok.push('$') if !$self.flattens;
@tok.push('(');
loop (my $i = 0; $i < $self.elems; $i++) {
@tok.push(Q:CgOp { (fvarlist_item (cast int (obj_getnum {$i})) (unbox fvarlist (@ {$self}))) }.perl);
@tok.push(', ') unless $i == $self.elems - 1 && $i;
}
@tok.push(')');
@tok.join;
}
method Numeric() { + @(self) }
method Str () { ~ @(self) }
method Bool () { ? @(self) }
method LISTSTORE(\$in) {
Q:CgOp {
(letn i (i 0)
vals (start_iter {$in})
tgts (unbox fvarlist (@ {self}))
ntgt (fvarlist_length (l tgts))
tgt (null var)
(whileloop 0 0 (< (l i) (l ntgt))
(prog
(l tgt (fvarlist_item (l i) (l tgts)))
(l i (+ (l i) (i 1)))
(ternary (var_islist (l tgt))
(letn ob (obj_newblank (class_ref mo List))
(iter_to_list (l ob) (l vals))
(l vals (vvarlist_new_empty))
(sink (methodcall (l tgt) LISTSTORE (newrwlistvar (l ob)))))
(assign (l tgt) (ternary (iter_hasflat (l vals))
(vvarlist_shift (l vals)) {Any})))))
{self})
};
}
}
constant Nil = Q:CgOp { (newrwlistvar (@ (box Parcel (fvarlist_new)))) };
my class List is Cool {
has @!items;
has @!rest;
has $!flat;
method new() {
Q:CgOp {
(letn n (obj_newblank (obj_llhow (@ {self})))
(setslot items (l n) (vvarlist_new_empty))
(setslot rest (l n) (vvarlist_new_empty))
(newrwlistvar (l n)))
};
}
method flat() {
self.iterator.flat
}
method Seq () {
Q:CgOp { (box Iterator (iter_copy_elems (unbox vvarlist (@ {self.eager.iterator})))) }.list
}
method clone() { Q:CgOp {
(letn selfo (@ {self})
new (obj_newblank (obj_llhow (l selfo)))
(setslot items (l new) (vvarlist_clone
(getslot items vvarlist (l selfo))))
(setslot rest (l new) (vvarlist_clone
(getslot rest vvarlist (l selfo))))
(newrwlistvar (l new)))
} }
method Capture () {
Q:CgOp {
(letn n (obj_newblank (obj_llhow (@ {Capture})))
(setslot positionals (l n) (vvarlist_to_fvarlist
(getslot items vvarlist (@ {self.eager}))))
(ns (l n)))
}
}
method perl(\$self:) {
$self // return $self.typename;
my @tok;
@tok.push('(');
@tok.push(.perl, ', ') for @$self;
@tok.pop if @tok >= 5;
@tok.push(').list');
@tok.push('.item') if !$self.flattens;
@tok.join
}
method !shift-item() { Q:CgOp {
(vvarlist_shift (getslot items vvarlist (@ {self})))
} }
method !pop-item() { Q:CgOp {
(vvarlist_pop (getslot items vvarlist (@ {self})))
} }
method !unshift-item(\$x) { Q:CgOp {
(rnull (vvarlist_unshift (getslot items vvarlist (@ {self})) {$x}))
} }
method shift() { self ?? self!shift-item !! Any }
method pop() { (+self) ?? self!pop-item !! Any }
method eager() { +self; self }
method head() { self ??
Q:CgOp { (vvarlist_item (i 0) (getslot items vvarlist (@ {self}))) } !!
Any
}
method elems() { +self }
method join($sep = '') {
my $t;
for unitem(self) -> $x {
$t = (defined($t) ?? ($t ~ $sep ~ $x) !! ~$x);
}
$t // '';
}
method Str() { self.join(" ") }
method sort($cmp = &infix:<leg>) {
my $l = @(self).eager;
Q:CgOp {
(letn n (obj_newblank (obj_llhow (@ {List})))
(setslot items (l n) (vvarlist_sort (@ {$cmp})
(getslot items vvarlist (@ {$l}))))
(setslot rest (l n) (vvarlist_new_empty))
(newrwlistvar (l n)))
}
}
method reverse() { reverse( @(self) ); }
method plan(*@items) {
Q:CgOp {
(rnull
(vvarlist_append (getslot rest vvarlist (@ {self}))
(unbox vvarlist (@ {@items.iterator}))))
}
}
method push(\|$args) { Q:CgOp {
(letn iter (vvarlist_from_fvarlist (unbox fvarlist (@ {$args})))
targ (getslot rest vvarlist (@ {self}))
(sink (vvarlist_shift (l iter)))
(ternary (== (i 0) (vvarlist_count (l targ)))
(l targ (getslot items vvarlist (@ {self})))
(prog))
(whileloop 0 0 (iter_hasflat (l iter))
(vvarlist_push (l targ) (nsw (@ (vvarlist_shift (l iter))))))
{Nil})
} }
method unshift(*@a) {
for reverse(@a) -> $v { self!unshift-item(anon $new = $v) }
}
method kv() { my $i = 0; self.map({ $i++, $_ }) }
}
my class Array is List {
method LISTSTORE(\$in) {
Q:CgOp {
(letn iter (vvarlist_new_empty)
into (vvarlist_new_empty)
sobj (@ {self})
(vvarlist_push (l iter) {$in})
(whileloop 0 0 (iter_hasflat (l iter))
(vvarlist_push (l into) (vvarlist_shift (l iter))))
(setslot items (l sobj) (iter_copy_elems (l into)))
(setslot rest (l sobj) (l iter))
(newrwlistvar (l sobj)))
};
}
method perl(\$self:) {
$self // return $self.typename;
"[" ~ $self.map(*.perl).join(', ') ~ "]" ~ ($self.flattens ?? ".list" !! "");
}
}
my class Hash {
method new() { unitem(Q:CgOp { (box Hash (varhash_new)) }) }
method hash() { unitem(self) }
method Capture () {
Q:CgOp {
(letn n (obj_newblank (obj_llhow (@ {Capture})))
(setslot positionals (l n) (fvarlist_new))
(setslot named (l n) (varhash_dup
(unbox varhash (@ {self}))))
(ns (l n)))
}
}
method keys() { Q:CgOp { (bif_hash_keys {self}) } }
method values() { Q:CgOp { (bif_hash_values {self}) } }
method pairs() { Q:CgOp { (bif_hash_pairs {self}) } }
method list() { Q:CgOp { (bif_hash_pairs {self}) } }
method kv() { Q:CgOp { (bif_hash_kv {self}) } }
method Numeric() { +@(self) }
method invert() {
my %new;
for self.keys -> $k { %new{self{$k}} = $k }
%new
}
method LISTSTORE(\$in) {
Q:CgOp {
(letn iter (vvarlist_new_empty)
into (varhash_new)
sobj (@ {self})
(vvarlist_push (l iter) {$in})
(whileloop 0 0 (iter_hasflat (l iter))
(letn elt (@ (vvarlist_shift (l iter)))
(ternary (obj_isa (l elt) (class_ref mo Pair))
(varhash_setindex (obj_getstr (getslot key var (l elt)))
(l into) (nsw (@ (getslot value var (l elt)))))
(ternary (iter_hasflat (l iter))
(varhash_setindex (obj_getstr (ns (l elt))) (l into)
(nsw (@ (vvarlist_shift (l iter)))))
(sink (die "Unmatched key in Hash.LISTSTORE"))))))
(setbox (l sobj) (l into))
(newrwlistvar (l sobj)))
};
}
method delete-key($str) {
Q:CgOp {
(ternary (obj_is_defined (@ {self}))
(letn r (unbox varhash (@ {self}))
k (obj_getstr {$str})
old (ternary (varhash_contains_key (l r) (l k))
(varhash_getindex (l k) (l r))
{Any})
(varhash_delete_key (l r) (l k))
(l old))
{Any})
};
}
# Rakudo extensions compatibility - DO NOT USE
method delete($key) { self.{$key}:delete }
method exists($key) { self.{$key}:exists }
method perl(\$self:) {
$self // return $self.typename;
'{' ~ @($self).map(*.perl).join(', ') ~ '}' ~
($self.flattens ?? ".hash" !! "")
}
}
augment class Any {
method delete-key($) {
defined(self) ?? die("Cannot use hash access on an object of type $.typename") !! Any
}
}
my class Enum is Cool {
has $.key;
has Mu $.value;
method Capture () {
Q:CgOp {
(letn n (obj_newblank (obj_llhow (@ {Capture})))
d (varhash_new)
(setslot positionals (l n) (fvarlist_new))
(setslot named (l n) (l d))
(varhash_setindex (obj_getstr {$!key})
(l d) {$!value})
(ns (l n)))
}
}
method kv() {
($.key, $.value);
}
method perl() { defined(self) ?? (self.key.perl ~ ' => ' ~ self.value.perl) !! self.typename }
method pairs() {
self.flat;
}
}
my class Pair is Enum {
method Str() {
$.key ~ "\t" ~ $.value
}
}
# }}}
# List utilities {{{
sub _vivify_array_at_pos(\$self, $ix) {
Q:CgOp { (newvnewarrayvar (class_ref mo Any) {$self} (cast int (obj_getnum {$ix})) (@ {Any})) };
}
sub postcircumfix:<[ ]>(\$container, $index) {
$container.at-pos($index)
}
sub postcircumfix:<{ }>(\$container, $key, :$exists, :$delete, :$p, :$kv) {
$exists ?? $container.exists-key($key) !!
$delete ?? $container.delete-key($key) !!
$p ?? $key => $container.at-key($key) !!
$kv ?? ($key, $container.at-key($key)) !!
$container.at-key($key)
}
my class GatherIterator is IterCursor {
has $.frame;
has $!reify;
method reify() {
my $*nextframe;
$!reify // ($!reify = (
Q:CgOp {
(letn getv (cotake (cast frame (@ {$!frame})))
(box Parcel (ternary (== (@ {EMPTY}) (@ (l getv)))
(fvarlist_new)
(fvarlist_new
(l getv)
{GatherIterator.new(frame => $*nextframe)}))))
}));
}
}
sub _gather($fr) {
&infix:<,>(GatherIterator.new(frame => $fr)).list
}
sub take(\|@pcl) { Q:CgOp { (take {@pcl.unwrap-single}) } }
sub infix:<< => >>($k, Mu $v) { $k => $v }
sub reverse(*@array) {
my @acc;
while @array { @acc.push(@array.pop) }
@acc;
}
sub push(@array, *@stuff) { @array.push(@stuff) }
sub unshift(@array, *@stuff) { @array.unshift(@stuff) }
sub pop(@array) { @array.pop }
sub shift(@array) { @array.shift }
sub join($tween, *@stuff) { @stuff.join($tween) }
sub invert(%h) { %h.invert }
sub keys(%h) { %h.keys }
sub values(%h) { %h.values }
sub grep(Mu $filter, *@items) { grep($filter, @items) }
sub map($callback, *@items) { map($callback, @items) }
sub sort(*@bits) { @bits.sort }
sub first(Mu $test, *@bits) { @bits.first($test) }
sub _array_constructor(\$parcel) { _array_constructor($parcel) }
sub _hash_constructor(\$parcel) { my $r := (anon %hash = $parcel); $r }
sub _make_capture(|$c) { $c }
sub _newtiedscalar(Mu $type, $bind, $fetch, $store) {
Q:CgOp { (var_new_tied (obj_llhow (@ {$type})) (@ {$bind}) (@ {$fetch}) (@ {$store})) }
}
sub infix:<Z>(\|$pcl) {
Q:CgOp { (bif_zip (b 0) (unbox fvarlist (@ {$pcl}))) }
}
sub infix:<X>(\|$pcl) {
Q:CgOp { (bif_cross (b 0) (unbox fvarlist (@ {$pcl}))) }
}
sub zipop(\|$pcl) {
Q:CgOp { (bif_zip (b 1) (unbox fvarlist (@ {$pcl}))) }
}
sub crossop(\|$pcl) {
Q:CgOp { (bif_cross (b 1) (unbox fvarlist (@ {$pcl}))) }
}
sub reduceop($triangle, $list, $right, $chain, $func, *@items) {
if $triangle {
if $chain {
gather {
my $ok = True;
if @items {
take True;
my Mu $last = shift @items;
while @items {
my Mu $next = shift @items;
my Mu $val ::= ($ok &&= $func($last, $next));
take $val;
$last = $next;
}
}
}
}
elsif $list {
my @pool;
gather {
while @items {
push @pool, shift @items;
take reduceop(False, $list, $right, $chain, $func, @pool);
}
}
}
elsif $right {
gather {
while @items >= 2 {
my Mu $right ::= @items.pop;
take $right;
my Mu $left = @items.pop;
@items.push($func($left,$right));
}
if @items {
my Mu $last ::= @items.shift;
take $last;
}
}
}
else { # left assoc
gather {
if @items {
my Mu $cumu ::= @items.shift;
take $cumu;
while @items {
my Mu $new ::= ($cumu ::= $func($cumu, @items.shift));
take $new;
}
}
}
}
}
else {
if $list {
$func(|@items);
}
elsif $chain {
my $ok = True;
while @items >= 2 {
$ok &&= $func(@items[0], @items[1]);
shift @items;
}
$ok;
}
elsif $right {
while @items >= 2 {
my Mu $r = @items.pop;
my Mu $l = @items.pop;
@items.push($func($l,$r));
}
@items ?? @items[0] !! 0; # XXX identity
}
else { # left
while @items >= 2 {
my Mu $l = @items.shift;
my Mu $r = @items.shift;
@items.unshift($func($l,$r));
}
@items ?? @items[0] !! 0; # XXX identity
}
}
}
# }}}
# Regular expression support {{{
my class Cursor {
method suppose($rx) {
my $*IN_SUPPOSE = True;
my $*FATALS = 0;
my @*WORRIES;
my %*WORRIES;
my $*HIGHWATER = -1;
my $*HIGHEXPECT = {};
try {
my $ret = head($rx(self));
if ($ret) { return $ret }
};
return ();
}
method O (*%hash) {
Q:CgOp { (cursor_O (cast cursor (@ {self}))
(unbox varhash (@ {%hash}))) }
}
method ast () { Q:CgOp { (ns (cursor_ast (cast cursor (@ {self})))) } }
method list () { @( self.Capture ) }
method flat () { @( self.Capture ) }
method iterator () { self.flat.iterator }
method hash () { %( self.Capture ) }
method Capture () { Q:CgOp {
(letn cap (obj_newblank (obj_llhow (@ {Capture})))
(cursor_unpackcaps (cast cursor (@ {self})) (l cap))
(newscalar (l cap)))
} }
method new($str, $act?) { Q:CgOp { (ns (cursor_start
(@ {self}) (obj_getstr {$str}) (@ {$act}))) } }
method pos() { Q:CgOp { (box Num (cast num (cursor_pos
(cast cursor (@ {self}))))) } }
method to() { Q:CgOp { (box Num (cast num (cursor_pos
(cast cursor (@ {self}))))) } }
method cursor($np) { Q:CgOp { (ns (cursor_butpos
(cast cursor (@ {self}))
(cast int (obj_getnum {$np})))) } }
method orig() { Q:CgOp {
(box Str (cursor_backing (cast cursor (@ {self})))) } }
method ws() { Q:CgOp { (cursor_dows (cast cursor (@ {self}))) } }
method CURSOR() { self }
token alpha { <+INTERNAL::alpha> } #OK
}
my class Match is Cool {
method ACCEPTS($) { self // nextsame }
method list () { @( self.Capture ) }
method hash () { %( self.Capture ) }
method flat () { @( self.Capture ) }
method iterator () { self.flat.iterator }
method Numeric() { +(~self) }
method keys () { keys %(self) }
method Capture () { Q:CgOp {
(letn cap (obj_newblank (obj_llhow (@ {Capture})))
(cursor_unpackcaps (cast cursor (@ {self})) (l cap))
(newscalar (l cap)))
} }
method new($) { die "Match.new NYI" }
method from() { Q:CgOp { (box Num (cast num (cursor_from
(cast cursor (@ {self}))))) } }
method to() { Q:CgOp { (box Num (cast num (cursor_pos
(cast cursor (@ {self}))))) } }
method pos() { self.to }
method orig() { Q:CgOp {
(box Str (cursor_backing (cast cursor (@ {self})))) } }
method ast () { Q:CgOp { (ns (cursor_ast (cast cursor (@ {self})))) } }
method chars() { defined(self) ?? $.to - $.from !! 0 }
method perl() {
!defined(self) ?? self.typename !!
"#<match from({ self.from }) to({ self.to }) text({ self }) pos({ @(self).perl }) named({ %(self).perl })>"
}
method CURSOR() { Q:CgOp { (ns (cursor_unmatch (cast cursor (@ {self})))) } }
method cursor() { Q:CgOp { (ns (cursor_unmatch (cast cursor (@ {self})))) } }
method reduced() { Q:CgOp { (box Str (cursor_reduced (cast cursor (@ {self})))) } }
method synthetic(:$cursor!, :$method!, :@captures!, :$from!, :$to!) {
my $*match;
Q:CgOp {
(prog
(cursor_synthetic
(cast cursor (@ {$cursor})) (obj_getstr {$method})
(cast int (obj_getnum {$from}))
(cast int (obj_getnum {$to}))
{@captures})
{$*match})
};
}
}
my class Regex is Sub {
method Bool() {
return False unless defined self;
my $fr = caller;
# Hack - skip ExitRunloop frame
$fr = $fr.caller unless $fr.line;
Q:CgOp {
(letn res {self.ACCEPTS($fr.hints('$_'))}
(set_status (s $*/) {$/})
(bif_bool (l res)))
};
}
method ACCEPTS($st) {
return $st.^does(self) unless defined self;
Q:CgOp {
(letn ix (i 0)
str (obj_getstr {$st})
max (str_length (l str))
incr (cursor_start (@ {Cursor}) (l str) (@ {Any}))
csr (null cursor)
iter (null vvarlist)
(whileloop 0 0 (<= (l ix) (l max)) (prog
(l csr (cursor_butpos (l incr) (l ix)))
(l ix (+ (l ix) (i 1)))
(l iter (vvarlist_new_singleton
(subcall (@ {self}) (ns (l csr)))))
(ternary (iter_hasflat (l iter))
(letn val (vvarlist_shift (l iter))
(set_status (s $*/) (l val))
(return (newrwlistvar (@ (l val))) (l val)))
(prog))))
(set_status (s $*/) {Match})
{Match})
};
}
}
sub _substitute(\$target, $regex, $repl) {
my $st = ~$target;
if $regex.ACCEPTS($st) {
Q:CgOp { (rnull (set_status (s '$*/') {$/})) };
$target = (substr($st, 0, $/.from) ~ $repl() ~
substr($st, $/.to, (chars($st) - $/.to)));
True;
} else {
False;
}
}
sub make($x) { make $x }
my class Grammar is Cursor {
method parse($text, :$rule = "TOP", :$actions) {
my $match = (head grep { $_.to == chars $text },
self.new($text, $actions)."$rule"()) // self;
Q:CgOp { (rnull (set_status (s '$*/') {$match})) };
$match;
}
}
# }}}
# Other operators {{{
constant Inf = 1 / 0;
my class RangeIter is IterCursor {
has $.current;
has $.limit;
has $.exclusive;
method reify() {
($!exclusive ?? ($!current >= $!limit) !! ($!current > $!limit))
?? Nil !! ($!current, RangeIter.new(current => $!current + 1,
limit => $!limit, exclusive => $!exclusive));
}
}
my class Range is Cool {
has $.min;
has $.max;
has $.excludes_min = False;
has $.excludes_max = False;
method new($min, $max, :$excludes_min = False, :$excludes_max = False) {
unitem(self.CREATE(min => ($min.^isa(Whatever) ?? -Inf !! $min),
max => ($max.^isa(Whatever) ?? Inf !! $max),
:$excludes_min, :$excludes_max));
}
method list() { self.iterator.list }
method flat() { self.iterator.flat }
method bounds() { $.min, $.max }
method from() { $.min }
method to() { $.max }
method iterator() {
&infix:<,>(RangeIter.new(:current($!excludes_min ?? $!min + 1 !! $!min),
:limit($!max), :exclusive($!excludes_max))).iterator
}
method Str() { self.perl }
method perl() {
( $.min.perl,
('^' if $.excludes_min),
'..',
('^' if $.excludes_max),
$.max.perl
).join('');
}
method ACCEPTS($topic) {
!defined(self) ?? ($topic.^isa(Range)) !!
($topic.^isa(Range) ??
(($.min == $topic.min)
&& ($.max == $topic.max)
&& ($.excludes_min == $topic.excludes_min)
&& ($.excludes_max == $topic.excludes_min)) !!
(self!min_test($topic) && self!max_test($topic)))
}
method !max_test($topic) {
$topic < $.max || (!$.excludes_max && !($topic > $.max));
}
method !min_test($topic) {
$.min < $topic || (!$.excludes_min && !($.min > $topic));
}
}
sub infix:<..> ($a, $b) { Range.new($a, $b) }
sub infix:<..^> ($a, $b) { Range.new($a, $b, :excludes_max) }
sub infix:<^..> ($a, $b) { Range.new($a, $b, :excludes_min) }
sub infix:<^..^> ($a, $b) { Range.new($a, $b, :excludes_min, :excludes_max) }
sub _hyper_type($val) {
#FIXME rewrite using roles
given $val {
when Hash { return 1 }
when List { return 2 }
when Parcel { return 2 }
when Range { return 2 }
default { return 0 }
}
}
sub hyperunary(&fun, \$obj) {
given _hyper_type($obj) {
when 1 {
my %out;
for $obj.kv -> $k, \$v {
%out{$k} = hyperunary(&fun, $v);
}
return %out;
}
when 2 {
my @out;
@out.push: $( hyperunary(&fun, $_) ) for $obj.list;
return @out;
}
when 3 {
my @out;
@out.push: $( hyperunary(&fun, $_) ) for $obj.list;
return $obj.new(@out);
}
when 0 {
return fun($obj);
}
}
}
sub _hyper_hash($dwiml, $dwimr, $fun, $left, $right) {
my %keys;
for $left.keys {
%keys{$_} = True if !$dwiml || ($right{$_}:exists);
}
for $right.keys {
%keys{$_} = True if !$dwimr || ($left{$_}:exists);
}
for %keys.keys {
%keys{$_} = hyper($dwiml, $dwimr, $fun, $left{$_}, $right{$_});
}
%keys
}
sub _hyper_posi($dwiml, $dwimr, $fun, $left, $right) {
my $lex = $left[*-1] ~~ Whatever;
my $rex = $right[*-1] ~~ Whatever;
my @out;
my $ix = 0;
loop {
my $lend; my $lv; my $rend; my $rv;
if $ix >= ($lex ?? $left - 1 !! $left) {
$lend = True;
$lv := $left[$lex ?? $left - 2 !! $left ?? $ix % $left !! 0];
} else {
$lv := $left[$ix];
}
if $ix >= ($rex ?? $right - 1 !! $right) {
$rend = True;
$rv := $right[$rex ?? $right - 2 !! $right ?? $ix % $right !! 0];
} else {
$rv := $right[$ix];
}
last if $lend && $rend;
die "Ran off end of non-dwimmy left" if $lend && !$dwiml && !$dwimr;
die "Ran off end of non-dwimmy right" if $rend && !$dwiml && !$dwimr;
last if $lend && !$dwiml;
last if $rend && !$dwimr;
@out.push: $( hyper($dwiml, $dwimr, $fun, $lv, $rv) );
$ix++;
}
@out;
}
sub hyper($dwiml, $dwimr, $fun, \$left, \$right) {
constant @htnames = 'scalar', 'Associative', 'Positional', #OK
'non-Positional Iterable';
my $h1 = _hyper_type($left);
my $h2 = _hyper_type($right);
if $h1 && $h2 && $h1 != $h2 {
die "Cannot mix @htnames[$h1] and @htnames[$h2] in hyperop";
}
if $h2 == 0 || $h1 == 0 {
if $h1 == 0 && $h2 == 0 { return $fun($left, $right) }
if $h2 {
if $dwiml {
return hyperunary(sub (\$x) { $fun($left,$x) }, $right);
}
} else {
if $dwimr {
return hyperunary(sub (\$x) { $fun($x,$right) }, $left);
}
}
die "Non-dwimmy scalar used with complex item";
}
given $h1 {
when 1 { return _hyper_hash($dwiml, $dwimr, $fun, $left, $right) }
when 2 { return _hyper_posi($dwiml, $dwimr, $fun, @$left, @$right) }
when 3 { die "Cannot hyper two unordered collections" }
}
}
sub infix:<%%> ($x,$y) { $x % $y == 0 }
sub infix:<?&> ($a, $b) { ?($a && $b) }
sub infix:<?|> ($a, $b) { ?($a || $b) }
sub infix:<?^> ($a, $b) { ?( +$a +^ $b ) }
sub prefix:<?^> ($a) { !$a }
sub prefix:<|> (\$item) { $item.Capture }
sub prefix:<^> ($limit) { 0 ..^ $limit }
sub prefix:<so> ($item) { ?$item }
sub infix:<xx> (\$list, $ct) { map { $list }, ^$ct }
sub prefix:<abs> ($x) { $x > 0 ?? $x !! -$x }
sub sqrt($x) { Q:CgOp { (_cgop bif_sqrt {$x}) } }
# XXX 'Order' type
sub infix:« <=> » ($a, $b) { $a < $b ?? -1 !! $a > $b ?? 1 !! 0 }
# XXX polymorphic equality
sub infix:<cmp> ($a, $b) { $a leg $b }
sub infix:<eqv> ($a, $b) { $a eq $b }
sub infix:<before> ($a, $b) { $a lt $b }
sub infix:<after> ($a, $b) { $a gt $b }
sub seqop($op) { $op } # TODO: Special case with hyper
sub reverseop($op) { sub (\$x, \$y) { $op($y, $x) } }
sub infix:<div> ($x,$y) { Q:CgOp { (_cgop bif_divop (i 4) {$x} {$y}) } }
sub infix:<mod> ($x,$y) { Q:CgOp { (_cgop bif_divop (i 5) {$x} {$y}) } }
sub infix:<~&> ($x, $y) { die "Buffer bitops NYI"; } #OK
sub infix:<~|> ($x, $y) { die "Buffer bitops NYI"; } #OK
sub infix:<~^> ($x, $y) { die "Buffer bitops NYI"; } #OK
sub infix:«~<» ($x, $y) { die "Buffer bitops NYI"; } #OK
sub infix:«~>» ($x, $y) { die "Buffer bitops NYI"; } #OK
sub prefix:<~^> ($x) { die "Buffer bitops NYI"; } #OK
sub prefix:<||> (\|$args) { die "Slicels NYI" } #OK
sub postfix:<i> ($item) { $item * i }
sub infix:<&> (\|$args) { die "Junctions NYI" } #OK
sub infix:<|> (\|$args) { die "Junctions NYI" } #OK
sub infix:<^> (\|$args) { die "Junctions NYI" } #OK
sub prefix:<sleep> ($x) { die "Asynchronous programming NYI" } #OK
sub infix:<does> ($obj, \$roles) { die "Retyping NYI" } #OK
sub infix:<minmax>(\|$args) { die "minmax NYI" } #OK
sub infix:<...>(\|$args) { die "Series op NYI" } #OK
sub infix:<...^>(\|$args) { die "Series op NYI" } #OK
sub infix:« ==> »(\|$args) { die "Feed ops NYI" } #OK
sub infix:« ==>> »(\|$args) { die "Feed ops NYI" } #OK
sub infix:« <== »(\|$args) { die "Feed ops NYI" } #OK
sub infix:« <<== »(\|$args) { die "Feed ops NYI" } #OK
sub eval($str) { Q:CgOp { (bif_simple_eval {$str}) } }
sub rungather($ ) { die "Run NYI" }
# }}}
# I/O stuff {{{
sub slurp($path) is unsafe { Q:CgOp { (box Str (slurp (unbox str (@ {$path})))) } }
sub spew($path,$text) is unsafe { Q:CgOp { (rnull (spew (unbox str (@ {$path.Str})) (unbox str (@ {$text.Str})))) } }
my class Instant {
has $.val;
method to-posix() { ($!val, False) }
}
sub term:« now »() {
Instant.new( val => Q:CgOp { (bif_now) } );
}
sub term:« time »() { Q:CgOp { (bif_now) } }
sub term:« rand »() { Q:CgOp { (bif_rand) } }
my class IO {
has $.path; # Str
method Str() { $.path }
method IO() { self }
method slurp() { slurp $.path }
method spew($text) { spew $.path, $text }
method combine(*@paths) {
die "Sorry, paths do not form a monoid." unless @paths;
my $acc = @paths.shift.IO;
for @paths { $acc = $acc.append($_) }
$acc
}
method perl() { $.path.perl ~ ".IO" }
method f() is unsafe { Q:CgOp { (box Bool (path_file_exists (obj_getstr {$!path}))) } }
method d() is unsafe { Q:CgOp { (box Bool (path_dir_exists (obj_getstr {$!path}))) } }
method e() is unsafe { Q:CgOp { (box Bool (path_any_exists (obj_getstr {$!path}))) } }
method relative($base) { $base.IO.append(self) }
method append($sub) { Q:CgOp { (box Str (path_combine (obj_getstr {self}) (obj_getstr {$sub}))) }.IO }
method but-extension($ext) { Q:CgOp { (box Str (path_change_ext (obj_getstr {self}) (obj_getstr {$ext}))) }.IO }
method realpath() is unsafe { Q:CgOp { (box Str (path_realpath (obj_getstr {self}))) }.IO }
method modified() is unsafe { Instant.new(val => Q:CgOp { (path_modified (obj_getstr {self})) }) }
}
augment class Str {
method IO() { IO.new(path => self) }
}
my class TextWriter {
method say(*@bits) { say @bits }
method print(*@bits) { print @bits }
}
my class TextReader {
method get() {
Q:CgOp {
(letn line (treader_getline (unbox treader (@ {self})))
(ternary (== (l line) (null str)) {Str} (box Str (l line))))
};
}
method slurp() {
Q:CgOp { (box Str (treader_slurp (unbox treader (@ {self})))) }
}
method getc() {
Q:CgOp {
(letn chi (treader_getc (unbox treader (@ {self})))
(ternary (>= (l chi) (int 0))
(box Str (str_chr (l chi)))
{Str}))
};
}
method lines() {
gather take my $l while ($l = self.get).defined;
}
}
sub open($filename) is unsafe {
Q:CgOp { (box TextReader (treader_open (obj_getstr {$filename}))) }
}
# TODO $*ARGFILES, multi
sub get($handle = $*IN) { $handle.get }
sub lines($filehandle = $*IN) { $filehandle.lines }
sub prompt($msg) { print $msg; $*IN.get }
sub getc($handle) { $handle.getc }
$PROCESS::IN ::= Q:CgOp { (box TextReader (treader_stdin)) };
$PROCESS::OUT ::= TextWriter.new;
@PROCESS::ARGS = unitem(Q:CgOp { (box Parcel (getargv)) });
# }}}
# This needs to be at the end because it screws up the parsing of everything
# after it.
sub infix:<,>(\|$t) { Q:CgOp { (newrwlistvar (@ {$t})) }; }
{YOU_ARE_HERE}
Jump to Line
Something went wrong with that request. Please try again.