Skip to content

Commit

Permalink
pragmas are now part of the current language braid
Browse files Browse the repository at this point in the history
  • Loading branch information
@TimToady
TimToady committed Feb 16, 2017
1 parent a431523 commit 282e59f
Show file tree
Hide file tree
Showing 3 changed files with 50 additions and 49 deletions.
39 changes: 20 additions & 19 deletions src/Perl6/Actions.nqp
View file
Expand Up @@ -485,9 +485,10 @@ register_op_desugar('p6for', -> $qast {
);
});

sub monkey_see_no_eval() {
nqp::existskey(%*PRAGMAS,'MONKEY-SEE-NO-EVAL')
?? %*PRAGMAS<MONKEY-SEE-NO-EVAL> # prevails if defined, can be either 1 or 0
sub monkey_see_no_eval($/) {
my $msne := $*LANG.pragma('MONKEY-SEE-NO-EVAL');
nqp::defined($msne)
?? $msne # prevails if defined, can be either 1 or 0
!! $*COMPILING_CORE_SETTING ||
try { $*W.find_symbol(['&MONKEY-SEE-NO-EVAL'])() } ||
nqp::getenvhash<RAKUDO_MONKEY_BUSINESS>;
Expand Down Expand Up @@ -791,7 +792,7 @@ class Perl6::Actions is HLL::Actions does STDActions {
unwantall($mainline, 'comp_unit');
$mainline.push(QAST::WVal.new( :value($*W.find_symbol(['Nil'])) ));
}
fatalize($mainline) if %*PRAGMAS<fatal>;
fatalize($mainline) if $/.CURSOR.pragma('fatal');

# Emit any worries. Note that unwanting $mainline can produce worries.
if @*WORRIES {
Expand Down Expand Up @@ -1375,7 +1376,7 @@ class Perl6::Actions is HLL::Actions does STDActions {
$past.annotate('statement_id', $id);

# only trace when running in source
if %*PRAGMAS<trace> && !$*W.is_precompilation_mode {
if $/.CURSOR.pragma('trace') && !$*W.is_precompilation_mode {
my $code := ~$/;

# don't bother putting ops for activating it
Expand Down Expand Up @@ -1522,7 +1523,7 @@ class Perl6::Actions is HLL::Actions does STDActions {
$BLOCK.push($past);
$BLOCK.node($/);
$BLOCK.annotate('handlers', %*HANDLERS) if %*HANDLERS;
fatalize($past) if %*PRAGMAS<fatal>;
fatalize($past) if $/.CURSOR.pragma('fatal');
make $BLOCK;
}
else {
Expand Down Expand Up @@ -2714,8 +2715,8 @@ class Perl6::Actions is HLL::Actions does STDActions {
}

method package_def($/) {
my $*LANG := $/.CURSOR;
my $package := $*LANG.package;
my $*LEAF := $/.CURSOR;
my $package := $*LEAF.package;
# Get the body block AST.
my $block;
if $<blockoid> {
Expand Down Expand Up @@ -3074,7 +3075,7 @@ class Perl6::Actions is HLL::Actions does STDActions {
$*W.throw($/, 'X::Syntax::Variable::MissingInitializer',
type => nqp::how($bind_constraint).name($bind_constraint),
implicit => !nqp::istype($*OFTYPE, NQPMatch) || !$*OFTYPE<colonpairs> || $*OFTYPE<colonpairs> && !$*OFTYPE<colonpairs>.ast<D> && !$*OFTYPE<colonpairs>.ast<U>
?? ':' ~ %*PRAGMAS{$what} ~ ' by pragma'
?? ':' ~ $/.CURSOR.pragma($what) ~ ' by pragma'
!! 0
);
}
Expand Down Expand Up @@ -3602,7 +3603,7 @@ class Perl6::Actions is HLL::Actions does STDActions {
# Add inlining information if it's inlinable; also mark soft if the
# appropriate pragma is in effect.
if $<deflongname> {
if %*PRAGMAS<soft> {
if $/.CURSOR.pragma('soft') {
$*W.find_symbol(['&infix:<does>'])($code, $*W.find_symbol(['SoftRoutine'], :setting-only));
}
else {
Expand Down Expand Up @@ -4023,7 +4024,7 @@ class Perl6::Actions is HLL::Actions does STDActions {
}

sub methodize_block($/, $code, $past, $signature, %sig_info, :$yada) {
my $*LANG := $/.CURSOR;
my $*LEAF := $/.CURSOR;
# Add signature binding code.
add_signature_binding_code($past, $signature, %sig_info<parameters>);

Expand Down Expand Up @@ -5801,7 +5802,7 @@ class Perl6::Actions is HLL::Actions does STDActions {
my str $op := ~$<op>;

# using nqp::op outside of setting
unless %*PRAGMAS<MONKEY-GUTS> || %*PRAGMAS<nqp> || $*COMPILING_CORE_SETTING {
unless $/.CURSOR.pragma('MONKEY-GUTS') || $/.CURSOR.pragma('nqp') || $*COMPILING_CORE_SETTING {
$/.CURSOR.typed_panic('X::NQP::NotFound', op => $op);
}

Expand Down Expand Up @@ -8666,7 +8667,7 @@ class Perl6::Actions is HLL::Actions does STDActions {
my $block := $*W.push_lexpad($/);
$block.blocktype('declaration_static');
if !$*SUPPOSING { # don't actually copy the thunk if inside <?before>
fatalize($to_thunk) if %*PRAGMAS<fatal>;
fatalize($to_thunk) if nqp::can($/,'CURSOR') ?? $/.CURSOR.pragma('fatal') !! $*LEAF.pragma('fatal');
$block.push(QAST::Stmts.new(autosink($to_thunk)));
}
$*W.pop_lexpad();
Expand Down Expand Up @@ -8937,7 +8938,7 @@ class Perl6::Actions is HLL::Actions does STDActions {
$all_literal := 0 unless nqp::istype($_,QAST::SpecialArg) ||
nqp::istype($_,QAST::Want) && nqp::istype($_[0],QAST::WVal) && $_[1] eq 'Ss' && nqp::istype($_[2],QAST::SVal);
}
$*W.throw($/, 'X::SecurityPolicy::Eval') unless $all_literal || monkey_see_no_eval();
$*W.throw($/, 'X::SecurityPolicy::Eval') unless $all_literal || monkey_see_no_eval($/);
}
WANTALL($args, 'capture_or_raw');
$args;
Expand Down Expand Up @@ -9589,7 +9590,7 @@ class Perl6::RegexActions is QRegex::P6Regex::Actions does STDActions {
$varast,
QAST::IVal.new( :value(%*RX<i> ?? 1 !! 0) ),
QAST::IVal.new( :value(%*RX<m> ?? 1 !! 0) ),
QAST::IVal.new( :value(monkey_see_no_eval()) ),
QAST::IVal.new( :value(monkey_see_no_eval($/)) ),
QAST::IVal.new( :value($*SEQ ?? 1 !! 0) ),
QAST::IVal.new( :value(0) ),
QAST::Op.new( :op<callmethod>, :name<new>,
Expand All @@ -9606,7 +9607,7 @@ class Perl6::RegexActions is QRegex::P6Regex::Actions does STDActions {
$<codeblock>.ast,
QAST::IVal.new( :value(%*RX<i> ?? 1 !! 0) ),
QAST::IVal.new( :value(%*RX<m> ?? 1 !! 0) ),
QAST::IVal.new( :value(monkey_see_no_eval()) ),
QAST::IVal.new( :value(monkey_see_no_eval($/)) ),
QAST::IVal.new( :value($*SEQ ?? 1 !! 0) ),
QAST::IVal.new( :value(1) ),
QAST::Op.new( :op<callmethod>, :name<new>,
Expand Down Expand Up @@ -9645,7 +9646,7 @@ class Perl6::RegexActions is QRegex::P6Regex::Actions does STDActions {
wanted($<var>.ast, 'assertvar2'),
QAST::IVal.new( :value(%*RX<i> ?? 1 !! 0) ),
QAST::IVal.new( :value(%*RX<m> ?? 1 !! 0) ),
QAST::IVal.new( :value(monkey_see_no_eval()) ),
QAST::IVal.new( :value(monkey_see_no_eval($/)) ),
QAST::IVal.new( :value($*SEQ ?? 1 !! 0) ),
QAST::IVal.new( :value(1) ),
QAST::Op.new( :op<callmethod>, :name<new>,
Expand Down Expand Up @@ -9793,7 +9794,7 @@ class Perl6::P5RegexActions is QRegex::P5Regex::Actions does STDActions {
QAST::IVal.new( :value(%*RX<i> ?? 1 !! 0) ),
QAST::IVal.new( :value(0) ),
QAST::IVal.new( :value(1) ),
QAST::IVal.new( :value(monkey_see_no_eval()) ),
QAST::IVal.new( :value(monkey_see_no_eval($/)) ),
QAST::IVal.new( :value(1) ),
QAST::Op.new( :op<callmethod>, :name<new>,
QAST::WVal.new( :value($*W.find_symbol(['PseudoStash']))),
Expand All @@ -9808,7 +9809,7 @@ class Perl6::P5RegexActions is QRegex::P5Regex::Actions does STDActions {
wanted($<var>.ast, 'p5var'),
QAST::IVal.new( :value(%*RX<i> ?? 1 !! 0) ),
QAST::IVal.new( :value(0) ),
QAST::IVal.new( :value(monkey_see_no_eval()) ),
QAST::IVal.new( :value(monkey_see_no_eval($/)) ),
QAST::IVal.new( :value($*SEQ ?? 1 !! 0) ),
QAST::IVal.new( :value($*INTERPOLATION) ) ),
:rxtype<subrule>, :subtype<method>, :node($/));
Expand Down
22 changes: 11 additions & 11 deletions src/Perl6/Grammar.nqp
View file
Expand Up @@ -267,8 +267,8 @@ role STD {
self
}
method typed_worry($type_str, *%opts) {
unless %*PRAGMAS<no-worries> {
%*PRAGMAS<fatal>
unless self.pragma('no-worries') {
self.pragma('fatal')
?? self.typed_sorry($type_str, |%opts)
!! @*WORRIES.push($*W.typed_exception(
self.MATCH(), nqp::split('::', $type_str), |%opts));
Expand Down Expand Up @@ -419,6 +419,7 @@ role STD {
}

token RESTRICTED {
:my $r := $*RESTRICTED || "(not)";
[ <?{ $*RESTRICTED }> [ $ || <.security($*RESTRICTED)> ] ]?
<!>
}
Expand All @@ -429,6 +430,7 @@ grammar Perl6::Grammar is HLL::Grammar does STD {
method TOP() {
# Language braid.
my $*LANG := self;
my $*LEAF := self; # the leaf cursor, workaround for when we can't pass via $/ into world
self.define_slang('MAIN', self.WHAT, self.actions);
self.define_slang('Quote', Perl6::QGrammar, Perl6::QActions);
self.define_slang('Regex', Perl6::RegexGrammar, Perl6::RegexActions);
Expand Down Expand Up @@ -1133,7 +1135,6 @@ grammar Perl6::Grammar is HLL::Grammar does STD {
:my $*SORRY_LIMIT := 10; # when sorrow turns to panic

# Extras.
:my %*PRAGMAS; # compiler-handled lexical pragmas in effect
:my @*NQP_VIOLATIONS; # nqp::ops per line number
:my %*HANDLERS; # block exception handlers
:my $*IMPLICIT; # whether we allow an implicit param
Expand Down Expand Up @@ -1208,6 +1209,7 @@ grammar Perl6::Grammar is HLL::Grammar does STD {

rule statementlist($*statement_level = 0) {
:my $*LANG := self;
:my $*LEAF := self;
:my %*LANG := self.shallow_copy(self.slangs); # XXX deprecated
:my %*HOW := self.shallow_copy(nqp::getlexdyn('%*HOW'));
:my %*HOWUSE := nqp::hash();
Expand Down Expand Up @@ -1379,7 +1381,6 @@ grammar Perl6::Grammar is HLL::Grammar does STD {
token blockoid {
:my $*CURPAD;
:my %*HANDLERS;
:my %*PRAGMAS := self.shallow_copy(nqp::getlexdyn('%*PRAGMAS'));
<.finishpad>
:my $borg := $*BORG;
:my $has_mystery := $*MYSTERY ?? 1 !! 0;
Expand Down Expand Up @@ -1620,15 +1621,13 @@ grammar Perl6::Grammar is HLL::Grammar does STD {
$*W.do_pragma_or_load_module($/,1);
$/.CURSOR.set_braid_from($*LANG);
nqp::rebless($/.CURSOR, $*LANG.WHAT);
# $/.CURSOR.braid."!dump"($/.Str) if %*PRAGMAS<MONKEY-WRENCH>;
$/.CURSOR.check_LANG_oopsies('use');
}
|| {
unless ~$<doc> && !%*COMPILING<%?OPTIONS><doc> {
$*W.do_pragma_or_load_module($/,1);
$/.CURSOR.set_braid_from($*LANG);
nqp::rebless($/.CURSOR, $*LANG.WHAT);
# $/.CURSOR.braid."!dump"($/.Str) if %*PRAGMAS<MONKEY-WRENCH>;
$/.CURSOR.check_LANG_oopsies('use');
}
}
Expand Down Expand Up @@ -1721,8 +1720,9 @@ grammar Perl6::Grammar is HLL::Grammar does STD {
token statement_prefix:sym<lazy> { <sym><.kok> <blorst> }
token statement_prefix:sym<sink> { <sym><.kok> <blorst> }
token statement_prefix:sym<try> {
:my %*PRAGMAS := self.shallow_copy(nqp::getlexdyn('%*PRAGMAS'));
<sym><.kok> { %*PRAGMAS<fatal> := 1; } <blorst>
<!!{ $/.CURSOR.clone_braid_from(self).set_pragma('fatal',1); }>
<sym><.kok> <blorst>
<.set_braid_from(self)>
}
token statement_prefix:sym<quietly> { <sym><.kok> <blorst> }
token statement_prefix:sym<gather> { <sym><.kok> <blorst> }
Expand Down Expand Up @@ -2373,7 +2373,7 @@ grammar Perl6::Grammar is HLL::Grammar does STD {
}
else {
# Augment. Ensure we can.
if !%*PRAGMAS<MONKEY-TYPING> && $longname.text ne 'Cool' {
if !$/.CURSOR.pragma('MONKEY-TYPING') && $longname.text ne 'Cool' {
$/.CURSOR.typed_panic('X::Syntax::Augment::WithoutMonkeyTyping');
}
elsif !$longname {
Expand Down Expand Up @@ -3936,7 +3936,6 @@ grammar Perl6::Grammar is HLL::Grammar does STD {
}

method EXPR(str $preclim = '') {
# self.braid."!dump"('EXPR ' ~ nqp::substr(self.orig, self.from, 1)) if %*PRAGMAS<MONKEY-WRENCH>;
# Override this so we can set $*LEFTSIGIL.
my $*LEFTSIGIL := '';
my $*IN_RETURN := 0;
Expand Down Expand Up @@ -4901,6 +4900,7 @@ if $*COMPILING_CORE_SETTING {
$*W.install_lexical_symbol($*W.cur_lexpad(), '%?LANG', $*W.p6ize_recursive(%*LANG));

$*LANG := self;
$*LEAF := self;
#$*W.install_lexical_symbol($*W.cur_lexpad(), '$?LANG', self);
return 1;
}
Expand Down Expand Up @@ -5249,7 +5249,7 @@ grammar Perl6::QGrammar is HLL::Grammar does STD {

my role CursorPackageNibbler {
method nibble-in-cursor($parent) {
my $*LANG := self;
my $*LEAF := self;
my $*PACKAGE := $*W.find_symbol(['Cursor']); self.set_package($*PACKAGE);
my %*ATTR_USAGES;
my $cur := nqp::findmethod($parent, 'nibbler')(self);
Expand Down

0 comments on commit 282e59f

Please sign in to comment.