Skip to content

Commit

Permalink
Browse files Browse the repository at this point in the history
Merge branch 'nom' into optimizer
  • Loading branch information
@moritz
moritz committed Oct 5, 2011
2 parents e19f726 + ff78b5b commit 2146e92
Show file tree
Hide file tree
Showing 14 changed files with 193 additions and 113 deletions.
5 changes: 5 additions & 0 deletions docs/ChangeLog
View file
@@ -1,3 +1,8 @@
New in 2011.10
+ performance improvements of MapIter
+ support @$foo style derefencing/coercion
+ Exception.backtrace

New in 2011.09
+ Rewritten meta object protocol and object storage
+ many speedups
Expand Down
2 changes: 1 addition & 1 deletion lib/Test.pm
View file
Expand Up @@ -269,7 +269,7 @@ multi sub eval_dies_ok(Str $code, $reason) {
my $ee = eval_exception($code);
if defined $ee {
# XXX no regexes yet in nom
my $bad_death = 0; #"$ee" ~~ / ^ 'Null PMC access ' /;
my $bad_death = $ee.Str.index('Null PMC access ').defined;
if $bad_death {
diag "wrong way to die: '$ee'";
}
Expand Down
19 changes: 12 additions & 7 deletions src/Perl6/Actions.pm
View file
Expand Up @@ -891,6 +891,9 @@ class Perl6::Actions is HLL::Actions {
method module_name($/) {
# XXX Needs re-doing.
my @name := Perl6::Grammar::parse_name(~$<longname>);
unless nqp::elems(@name) {
$/.CURSOR.panic('Cannot deal with an empty module name here');
}
my $var := PAST::Var.new(
:name(@name.pop),
:namespace(@name),
Expand Down Expand Up @@ -1038,16 +1041,19 @@ class Perl6::Actions is HLL::Actions {
$past.unshift(PAST::Var.new( :name('self'), :scope('lexical_6model') ));
}
elsif $twigil eq '^' || $twigil eq ':' {
$past := add_placeholder_parameter($/, $sigil, $desigilname, :named($twigil eq ':'));
$past := add_placeholder_parameter($/, $sigil, $desigilname,
:named($twigil eq ':'), :full_name($name));
}
elsif $name eq '@_' {
unless $*ST.nearest_signatured_block_declares('@_') {
$past := add_placeholder_parameter($/, '@', '_', :pos_slurpy(1));
$past := add_placeholder_parameter($/, '@', '_',
:pos_slurpy(1), :full_name($name));
}
}
elsif $name eq '%_' {
unless $*ST.nearest_signatured_block_declares('%_') || $*METHODTYPE {
$past := add_placeholder_parameter($/, '%', '_', :named_slurpy(1));
$past := add_placeholder_parameter($/, '%', '_', :named_slurpy(1),
:full_name($name));
}
}
elsif +@name > 1 {
Expand Down Expand Up @@ -3660,12 +3666,11 @@ class Perl6::Actions is HLL::Actions {
}

# Adds a placeholder parameter to this block's signature.
sub add_placeholder_parameter($/, $sigil, $ident, :$named, :$pos_slurpy, :$named_slurpy) {
sub add_placeholder_parameter($/, $sigil, $ident, :$named, :$pos_slurpy, :$named_slurpy, :$full_name) {
# Ensure we're not trying to put a placeholder in the mainline.
my $block := $*ST.cur_lexpad();
if $block<IN_DECL> eq 'mainline' {
$/.CURSOR.panic("Cannot declare placeholder parameter $sigil" ~
($named ?? ':' !! '^') ~ "$ident in the mainline");
$/.CURSOR.panic("Cannot use placeholder parameter $full_name in the mainline");
}

# Obtain/create placeholder parameter list.
Expand Down Expand Up @@ -3718,7 +3723,7 @@ class Perl6::Actions is HLL::Actions {
# Add variable declaration, and evaluate to a lookup of it.
my %existing := $block.symbol($name);
if +%existing && !%existing<placeholder_parameter> {
$/.CURSOR.panic("Redeclaration of symbol $name as a placeholder parameter");
$/.CURSOR.panic("Redeclaration of symbol $full_name as a placeholder parameter");
}
$block[0].push(PAST::Var.new( :name($name), :scope('lexical_6model'), :isdecl(1) ));
$block.symbol($name, :scope('lexical_6model'), :placeholder_parameter(1));
Expand Down
8 changes: 6 additions & 2 deletions src/core/Exception.pm
View file
@@ -1,6 +1,8 @@
my class Exception {
has $!ex;

method backtrace() { Backtrace.new(self) }

method Str() {
nqp::p6box_s(nqp::atkey($!ex, 'message'))
}
Expand Down Expand Up @@ -58,8 +60,10 @@ do {
);
if is_runtime($ex.backtrace) {
my $e := EXCEPTION($ex);
say $e;
say Backtrace.new($e);
my Mu $err := pir::getstderr__P();
$err.print: $e;
$err.print: "\n";
$err.print: Backtrace.new($e);
} else {
my Mu $err := pir::getstderr__P();
$err.print: "===SORRY!===\n";
Expand Down
1 change: 0 additions & 1 deletion src/core/Exceptions.pm
View file
@@ -1,7 +1,6 @@
# XXX should really be my X::Base eventually
my package X {
class Base is Exception {
has $.backtrace;
has $.message;

multi method Str(Base:D:) {
Expand Down
190 changes: 115 additions & 75 deletions src/core/Main.pm
View file
@@ -1,18 +1,59 @@
# TODO:
# * Strengthen val()
# * Radix-notated Int
# * Make val() available globally
# * $?USAGE
# * Create $?USAGE at compile time
# * Make $?USAGE available globally
# * Command-line parsing
# * Like -- , first non-switch kills option parsing
# * Allow : as option indicator (XXXX: no spaces before argument?)
# * Single-dash options (don't allow spaces before argument)
# * Allow both = and space before argument of double-dash args
# * Non-Bool options that get negated become "but False"
# * Comma-separated list values
# * Allow exact Perl 6 forms, quoted away from shell
# * Fix remaining XXXX

my sub MAIN_HELPER($retval = 0) {
# Do we have a MAIN at all?
my $m = callframe(1).my<&MAIN>;
return $retval unless $m;

# We found MAIN, let's process the command line arguments accordingly
# Temporary stand-in for magic val() routine
my sub hack-val ($v) {
# Convert to native type if appropriate
my grammar CLIVal {
token TOP { ^ <numlike> $ }
token numlike {
[
| <[\-+]>? \d+ '/' <[\-+]>? \d+
| <[\-+]>? \d+ '.' \d+ 'e' <[\-+]>? \d+
| <[\-+]>? \d+ 'e' <[\-+]>? \d+
| <[\-+]>? \d+ '.' \d+
| <[\-+]>? \d+
]
}
};

my $val;
if CLIVal.parse($v) { $val := +$v }
else { $val := $v }
return $val if $val ~~ Str;

# Mix in original stringifications
my role orig-string[$orig] {
method Str { $orig.Str }
method gist { $orig.gist }
};
return $val but orig-string[$v];
}

# Convert raw command line args into positional and named args for MAIN
my sub process-cmd-args (@args is copy) {
my (@positional-arguments, %named-arguments);
while (@args) {
my $passed_value = @args.shift;
if $passed_value.substr(0, 1) eq '-'
&& $passed_value.substr(1, 1) ne '-' {
# TODO: warn?
@positional-arguments.push: $passed_value;
}

my $negate = False;
if $passed_value.substr(0, 2) eq '--' {
my $arg = $passed_value.substr(2);
Expand All @@ -22,91 +63,90 @@ my sub MAIN_HELPER($retval = 0) {
}

if $arg eq '' {
@positional-arguments.push: @args;
@positional-arguments.push: @args.map: &hack-val;
last;
} elsif $arg.index('=').defined {
my ($name , $value) = $arg.split('=', 2);
if $negate {
note "Trouble while parsing comand line argument '$arg': Cannot negate something which has an explicit value - ignoring the argument.\n";
next;
}
%named-arguments.push: $name => $value;
%named-arguments.push: $name => hack-val($value);
} else {
%named-arguments.push: $arg => !$negate;
}
} else {
@positional-arguments.push: $passed_value;
# TODO: warn if argument starts with single '-'?
@positional-arguments.push: hack-val($passed_value);
}
}

return @positional-arguments, %named-arguments
}

my ($p, $n) = process-cmd-args(@*ARGS);
# Generate $?USAGE string (default usage info for MAIN)
my sub gen-usage () {
my @help-msgs;
my $prog-name = $*PROGRAM_NAME eq '-e' ?? "-e '...'" !! $*PROGRAM_NAME;
for $m.candidates -> $sub {
my (@required-named, @optional-named, @positional);
for $sub.signature.params -> $param {
my $argument;
if $param.named {
my @names = $param.named_names.reverse;
$argument = @names.map('--' ~ *).join('|');
my $type = $param.type;
$argument ~= "=<$type>" unless $type ~~ 'Bool';
if $param.optional {
@optional-named.push("[$argument]");
}
else {
@required-named.push($argument);
}
}
else {
my $constraints = ~$param.constraints;
my $simple_const = $constraints && $constraints !~~ /^_block/;
$argument = $param.name ?? '<' ~ $param.name.substr(1) ~ '>' !!
$simple_const ?? $constraints !!
'<' ~ $param.type ~ '>' ;

$argument = "[$argument ...]" if $param.slurpy;
$argument = "[$argument]" if $param.optional;
@positional.push($argument);
}
}
my $msg = join(' ', $prog-name, @required-named, @optional-named, @positional);
@help-msgs.push($msg);
}
my $usage = "Usage:\n" ~ @help-msgs.map(' ' ~ *).join("\n");
return $usage;
}

# Process command line arguments
my ($p, $n) = process-cmd-args(@*ARGS).lol;

# TODO: check if a dispatch is possible, and if not,
# do some USAGE magic.
return $m(|@($p), |%($n));
# Generate default $?USAGE message
my $?USAGE = gen-usage();

# # We could not find the correct main to dispatch to!
# # Let's try to run the user defined USAGE sub
# my $h = callframe(1).my<&USAGE>;
# return $h() if $h;
#
# # We could not find a user defined USAGE sub!
# # Let's display a default USAGE message
# my @aliases;
# my @help-msgs;
# for $m.candidates -> $sub {
# my $sig = $sub.signature;
# my @arguments = ();
# for $sig.params -> $param {
# my $argument;
# if $param.named {
# my $param-name = $param.name.substr(1); # Remove $
# my %alias = $param.named_names.elems == 2
# ?? get-aliases($param.named_names.hash)
# !! ();
#
# my $long-name = %alias{$param-name} // $param-name;
# $argument = "--$long-name"
# ~ ($param.type ~~ Bool
# ?? '' !! "=value-of-$long-name");
#
# if %alias {
# @aliases.push: " -" ~ %alias.pairs[0].key()
# ~ " instead of --$long-name"
# }
# } else {
# $argument = $param.name ?? $param.name.substr(1)
# !! ~$param.constraints;
# #TODO: fixme
# $argument = 'param' if $argument ~~ /^_block\d+$/;
#
# if $param.slurpy {
# $argument ~= " [more [...]]";
# }
# }
# $argument = "[$argument]" if $param.optional;
# if $param.named {
# @arguments.unshift($argument);
# } else {
# @arguments.push($argument);
# }
# }
# @help-msgs.push(
# ($*PROGRAM_NAME eq '-e' ?? "-e '...'" !! $*PROGRAM_NAME)
# ~ ' ' ~ @arguments.join(' ');
# );
# }
# my $msg = "Usage:\n" ~ @help-msgs.join("\nor\n");
# if @aliases {
# $msg ~= "\nYou can use\n" ~ @aliases.join("\n")
# }
# if @*ARGS ~~ ['--help'] {
# $*OUT.say($msg);
# } else {
# $*ERR.say($msg);
# exit 29; #TODO: Better return value
# }
# If dispatch to MAIN is possible, do so
if $m.candidates_matching(|@($p), |%($n)).elems {
return $m(|@($p), |%($n));
}

# We could not find the correct MAIN to dispatch to!
# Let's try to run a user defined USAGE sub
my $h = callframe(1).my<&USAGE>;
return $h() if $h;

# We could not find a user defined USAGE sub!
# Let's display the default USAGE message
if ($n<help>) {
$*OUT.say($?USAGE);
exit 1;
}
else {
$*ERR.say($?USAGE);
exit 2;
}
}

0 comments on commit 2146e92

Please sign in to comment.