Skip to content

Commit

Permalink
Browse files Browse the repository at this point in the history
Vectorized the +*-/ (though integer / isn't right)
  • Loading branch information
jayemerson committed Jul 16, 2011
1 parent 7c20a2b commit 8be71ad
Show file tree
Hide file tree
Showing 7 changed files with 227 additions and 27 deletions.
5 changes: 3 additions & 2 deletions RANDOM.NOTES
Expand Up @@ -297,7 +297,8 @@ Integer
Float
String



# Customized operators:
#https://github.com/partcl/partcl-nqp/blob/master/src/Partcl/Operators.pm#L22
# https://github.com/partcl/partcl-nqp/blob/master/src/Partcl/Grammar.pm#L177


1 change: 1 addition & 0 deletions VERSION
@@ -0,0 +1 @@
0.0.1, July 15, 2011.
1 change: 1 addition & 0 deletions src/nqr.pir
Expand Up @@ -25,6 +25,7 @@ object.
=cut

.HLL 'nqr'
.loadlib 'io_ops'
#.loadlib 'squaak_group' # JAY: Unchanged at the moment

.namespace []
Expand Down
12 changes: 11 additions & 1 deletion src/nqr/Compiler.pm
Expand Up @@ -5,11 +5,21 @@
class nqr::Compiler is HLL::Compiler;

INIT {
my $version := Q:PIR { # Surely this could be done better in NQP
.local string filename
.local pmc data_file
.local string version
filename = 'VERSION'
data_file = open filename, 'r'
version = readline data_file
close data_file
%r = box version
};
nqr::Compiler.language('nqr');
nqr::Compiler.parsegrammar(nqr::Grammar);
nqr::Compiler.parseactions(nqr::Actions);
nqr::Compiler.commandline_banner("\nNot Quite R for Parrot VM.\n\n");
nqr::Compiler.commandline_banner("\nNot Quite R for Parrot VM, Version $version\n");
nqr::Compiler.commandline_prompt('> ');
}

Expand Down
16 changes: 10 additions & 6 deletions src/nqr/Grammar.pm
Expand Up @@ -211,17 +211,21 @@ token prefix:sym<!> { <sym> <O('%unary-not, :pirop<isfalse>')> }

# JAY: Added trying to do ':'
#token infix:sym<:> { <sym> <O('%sequence')> }
token infix:sym<*> { <sym> <O('%multiplicative, :pirop<mul>')> }

#token infix:sym<*> { <sym> <O('%multiplicative, :pirop<mul>')> }
token infix:sym<*> { <sym> <O('%multiplicative')> }

token infix:sym<%> { <sym> <O('%multiplicative, :pirop<mod>')> }
token infix:sym</> { <sym> <O('%multiplicative, :pirop<div>')> }

# Vectorizing addition?
#token infix:sym</> { <sym> <O('%multiplicative, :pirop<div>')> }
token infix:sym</> { <sym> <O('%multiplicative')> }

#token infix:sym<+> { <sym> <O('%additive, :pirop<add>')> }
#https://github.com/partcl/partcl-nqp/blob/master/src/Partcl/Operators.pm#L22
# https://github.com/partcl/partcl-nqp/blob/master/src/Partcl/Grammar.pm#L177
token infix:sym<+> { <sym> <O('%additive')> }

token infix:sym<-> { <sym> <O('%additive, :pirop<sub>')> }
#token infix:sym<-> { <sym> <O('%additive, :pirop<sub>')> }
token infix:sym<-> { <sym> <O('%additive')> }

token infix:sym<..> { <sym> <O('%additive, :pirop<concat>')> }

token infix:sym«<» { <sym> <O('%relational, :pirop<islt iPP>')> }
Expand Down
208 changes: 194 additions & 14 deletions src/nqr/Operators.pm
Expand Up @@ -6,57 +6,237 @@
# This while-looping avoids resizing after the first one...
# Avoiding the swap of $a and $b would require extra versions
# of the code... maybe worth it eventually for performance.

sub &infix:<+>($a, $b) {
my $tmp;
my $i;
if (length($a) == 1) {
$tmp := $a;
$a := $b;
$b := $tmp;
} # So now if one is length 1, it is the $b
$i := length($b) - 1;
if ( (pir::typeof($a[0]) eq 'Float') ||
(pir::typeof($b[0]) eq 'Float') ) {
my @ans := pir::new("ResizableFloatArray");
while ($i >= 0) {
@ans[$i] := $b[$i] + $a[0];
$i--;
}
return @ans;
} else {
my @ans := pir::new("ResizableIntegerArray");
while ($i >= 0) {
@ans[$i] := $b[$i] + $a[0];
$i--;
}
return @ans;
}
}
if (length($b) == 1) {
$i := length($a) - 1;
if ( (pir::typeof($a[0]) eq 'Float') ||
(pir::typeof($b[0]) eq 'Float') ) {
my @ans := pir::new("ResizableFloatArray");
$i := length($a) - 1;
while ($i >= 0) {
@ans[$i] := $a[$i] + $b[0];
$i--;
}
return @ans;
} else {
my @ans := pir::new("ResizableIntegerArray");
$i := length($a) - 1;
while ($i >= 0) {
@ans[$i] := $a[$i] + $b[0];
$i--;
}
return @ans;
}
} else { # Equal-length vectors (this could be some linear
# algebra library call, eventually?):
if (length($a) == length($b)) {
}
# Below, equal sized, or else in trouble.
if (length($a) == length($b)) {
$i := length($a) - 1;
if ( (pir::typeof($a[0]) eq 'Float') ||
(pir::typeof($b[0]) eq 'Float') ) {
my @ans := pir::new("ResizableFloatArray");
$i := length($a) - 1;
while ($i >= 0) {
@ans[$i] := $a[$i] + $b[$i];
$i--;
}
return @ans;
} else {
my @ans := pir::new("ResizableIntegerArray");
$i := length($a) - 1;
while ($i >= 0) {
@ans[$i] := $a[$i] + $b[$i];
$i--;
}
return @ans;
}
} else {
print("Vector recycling not allowed in infix:<+>\n");
return 0;
}
}

sub &infix:<->($a, $b) {
my $i;
if (length($a) == 1) {
$i := length($b) - 1;
if ( (pir::typeof($a[0]) eq 'Float') ||
(pir::typeof($b[0]) eq 'Float') ) {
my @ans := pir::new("ResizableFloatArray");
while ($i >= 0) {
@ans[$i] := $a[0] - $b[$i];
$i--;
}
return @ans;
} else {
print("Vector recycling not allowed in infix:<+>\n");
return 0;
my @ans := pir::new("ResizableIntegerArray");
while ($i >= 0) {
@ans[$i] := $a[0] - $b[$i];
$i--;
}
return @ans;
}
}
if (length($b) == 1) {
$i := length($a) - 1;
if ( (pir::typeof($a[0]) eq 'Float') ||
(pir::typeof($b[0]) eq 'Float') ) {
my @ans := pir::new("ResizableFloatArray");
while ($i >= 0) {
@ans[$i] := $a[$i] - $b[0];
$i--;
}
return @ans;
} else {
my @ans := pir::new("ResizableIntegerArray");
while ($i >= 0) {
@ans[$i] := $a[$i] - $b[0];
$i--;
}
return @ans;
}
}
# Below, equal sized, or else in trouble.
if (length($a) == length($b)) {
$i := length($a) - 1;
if ( (pir::typeof($a[0]) eq 'Float') ||
(pir::typeof($b[0]) eq 'Float') ) {
my @ans := pir::new("ResizableFloatArray");
while ($i >= 0) {
@ans[$i] := $a[$i] - $b[$i];
$i--;
}
return @ans;
} else {
my @ans := pir::new("ResizableIntegerArray");
while ($i >= 0) {
@ans[$i] := $a[$i] - $b[$i];
$i--;
}
return @ans;
}
} else {
print("Vector recycling not allowed in infix:<->\n");
return 0;
}
}


sub &infix:<*>($a, $b) {
my $i;
if (length($a) == 1) {
$i := length($b) - 1;
if ( (pir::typeof($a[0]) eq 'Float') ||
(pir::typeof($b[0]) eq 'Float') ) {
my @ans := pir::new("ResizableFloatArray");
while ($i >= 0) {
@ans[$i] := $b[$i] * $a[0];
$i--;
}
return @ans;
} else {
my @ans := pir::new("ResizableIntegerArray");
while ($i >= 0) {
@ans[$i] := $b[$i] * $a[0];
$i--;
}
return @ans;
}
}
if (length($b) == 1) {
$i := length($a) - 1;
if ( (pir::typeof($a[0]) eq 'Float') ||
(pir::typeof($b[0]) eq 'Float') ) {
my @ans := pir::new("ResizableFloatArray");
while ($i >= 0) {
@ans[$i] := $a[$i] * $b[0];
$i--;
}
return @ans;
} else {
my @ans := pir::new("ResizableIntegerArray");
while ($i >= 0) {
@ans[$i] := $a[$i] * $b[0];
$i--;
}
return @ans;
}
}
# Below, equal sized, or else in trouble.
if (length($a) == length($b)) {
$i := length($a) - 1;
if ( (pir::typeof($a[0]) eq 'Float') ||
(pir::typeof($b[0]) eq 'Float') ) {
my @ans := pir::new("ResizableFloatArray");
while ($i >= 0) {
@ans[$i] := $a[$i] * $b[$i];
$i--;
}
return @ans;
} else {
my @ans := pir::new("ResizableIntegerArray");
while ($i >= 0) {
@ans[$i] := $a[$i] * $b[$i];
$i--;
}
return @ans;
}
} else {
print("Vector recycling not allowed in infix:<*>\n");
return 0;
}
}

## Result will always be Float, as with R.
sub &infix:</>($a, $b) {
my $i;
if (length($a) == 1) {
$i := length($b) - 1;
my @ans := pir::new("ResizableFloatArray");
while ($i >= 0) {
@ans[$i] := $a[0] / $b[$i];
$i--;
}
return @ans;
}
if (length($b) == 1) {
$i := length($a) - 1;
my @ans := pir::new("ResizableFloatArray");
while ($i >= 0) {
@ans[$i] := $a[$i] / $b[0];
$i--;
}
return @ans;
}
# Below, equal sized, or else in trouble.
if (length($a) == length($b)) {
$i := length($a) - 1;
my @ans := pir::new("ResizableFloatArray");
while ($i >= 0) {
@ans[$i] := $a[$i] / $b[$i];
$i--;
}
return @ans;
} else {
print("Vector recycling not allowed in infix:</>\n");
return 0;
}
}


11 changes: 7 additions & 4 deletions src/nqr/Runtime.pm
Expand Up @@ -56,11 +56,14 @@ sub say(*@args) {
# Accepts an array, hash, or literal (incomplete checking),
# though checking a literal shouldn't be needed unless the
# query is length(5), perhaps? Not sure even then...

# Simple if we always have a Resizable*Array, right?
sub length($arg) {
if (pir::does($arg, "array") || pir::does($arg, "hash")) {
return pir::elements($arg);
}
return 1;
return pir::elements($arg);
#if (pir::does($arg, "array") || pir::does($arg, "hash")) {
# return pir::elements($arg);
#}
#return 1;
}

#################################################################
Expand Down

0 comments on commit 8be71ad

Please sign in to comment.