From 282e59f6a846c3a576b2f74dbc0759ac459e5266 Mon Sep 17 00:00:00 2001 From: TimToady Date: Thu, 16 Feb 2017 13:07:11 -0800 Subject: [PATCH] pragmas are now part of the current language braid --- src/Perl6/Actions.nqp | 39 ++++++++++++++++++++------------------- src/Perl6/Grammar.nqp | 22 +++++++++++----------- src/Perl6/World.nqp | 38 +++++++++++++++++++------------------- 3 files changed, 50 insertions(+), 49 deletions(-) diff --git a/src/Perl6/Actions.nqp b/src/Perl6/Actions.nqp index 3aaa13cf462..cc6217d3e2e 100644 --- a/src/Perl6/Actions.nqp +++ b/src/Perl6/Actions.nqp @@ -485,9 +485,10 @@ register_op_desugar('p6for', -> $qast { ); }); -sub monkey_see_no_eval() { - nqp::existskey(%*PRAGMAS,'MONKEY-SEE-NO-EVAL') - ?? %*PRAGMAS # 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; @@ -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; + fatalize($mainline) if $/.CURSOR.pragma('fatal'); # Emit any worries. Note that unwanting $mainline can produce worries. if @*WORRIES { @@ -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 && !$*W.is_precompilation_mode { + if $/.CURSOR.pragma('trace') && !$*W.is_precompilation_mode { my $code := ~$/; # don't bother putting ops for activating it @@ -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; + fatalize($past) if $/.CURSOR.pragma('fatal'); make $BLOCK; } else { @@ -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 $ { @@ -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 || $*OFTYPE && !$*OFTYPE.ast && !$*OFTYPE.ast - ?? ':' ~ %*PRAGMAS{$what} ~ ' by pragma' + ?? ':' ~ $/.CURSOR.pragma($what) ~ ' by pragma' !! 0 ); } @@ -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 $ { - if %*PRAGMAS { + if $/.CURSOR.pragma('soft') { $*W.find_symbol(['&infix:'])($code, $*W.find_symbol(['SoftRoutine'], :setting-only)); } else { @@ -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); @@ -5801,7 +5802,7 @@ class Perl6::Actions is HLL::Actions does STDActions { my str $op := ~$; # using nqp::op outside of setting - unless %*PRAGMAS || %*PRAGMAS || $*COMPILING_CORE_SETTING { + unless $/.CURSOR.pragma('MONKEY-GUTS') || $/.CURSOR.pragma('nqp') || $*COMPILING_CORE_SETTING { $/.CURSOR.typed_panic('X::NQP::NotFound', op => $op); } @@ -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 - fatalize($to_thunk) if %*PRAGMAS; + fatalize($to_thunk) if nqp::can($/,'CURSOR') ?? $/.CURSOR.pragma('fatal') !! $*LEAF.pragma('fatal'); $block.push(QAST::Stmts.new(autosink($to_thunk))); } $*W.pop_lexpad(); @@ -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; @@ -9589,7 +9590,7 @@ class Perl6::RegexActions is QRegex::P6Regex::Actions does STDActions { $varast, QAST::IVal.new( :value(%*RX ?? 1 !! 0) ), QAST::IVal.new( :value(%*RX ?? 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, :name, @@ -9606,7 +9607,7 @@ class Perl6::RegexActions is QRegex::P6Regex::Actions does STDActions { $.ast, QAST::IVal.new( :value(%*RX ?? 1 !! 0) ), QAST::IVal.new( :value(%*RX ?? 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, :name, @@ -9645,7 +9646,7 @@ class Perl6::RegexActions is QRegex::P6Regex::Actions does STDActions { wanted($.ast, 'assertvar2'), QAST::IVal.new( :value(%*RX ?? 1 !! 0) ), QAST::IVal.new( :value(%*RX ?? 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, :name, @@ -9793,7 +9794,7 @@ class Perl6::P5RegexActions is QRegex::P5Regex::Actions does STDActions { QAST::IVal.new( :value(%*RX ?? 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, :name, QAST::WVal.new( :value($*W.find_symbol(['PseudoStash']))), @@ -9808,7 +9809,7 @@ class Perl6::P5RegexActions is QRegex::P5Regex::Actions does STDActions { wanted($.ast, 'p5var'), QAST::IVal.new( :value(%*RX ?? 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, :subtype, :node($/)); diff --git a/src/Perl6/Grammar.nqp b/src/Perl6/Grammar.nqp index 2f848b7f14d..664ce8b2d00 100644 --- a/src/Perl6/Grammar.nqp +++ b/src/Perl6/Grammar.nqp @@ -267,8 +267,8 @@ role STD { self } method typed_worry($type_str, *%opts) { - unless %*PRAGMAS { - %*PRAGMAS + 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)); @@ -419,6 +419,7 @@ role STD { } token RESTRICTED { + :my $r := $*RESTRICTED || "(not)"; [ [ $ || <.security($*RESTRICTED)> ] ]? } @@ -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); @@ -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 @@ -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(); @@ -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; @@ -1620,7 +1621,6 @@ 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; $/.CURSOR.check_LANG_oopsies('use'); } || { @@ -1628,7 +1628,6 @@ 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; $/.CURSOR.check_LANG_oopsies('use'); } } @@ -1721,8 +1720,9 @@ grammar Perl6::Grammar is HLL::Grammar does STD { token statement_prefix:sym { <.kok> } token statement_prefix:sym { <.kok> } token statement_prefix:sym { - :my %*PRAGMAS := self.shallow_copy(nqp::getlexdyn('%*PRAGMAS')); - <.kok> { %*PRAGMAS := 1; } + + <.kok> + <.set_braid_from(self)> } token statement_prefix:sym { <.kok> } token statement_prefix:sym { <.kok> } @@ -2373,7 +2373,7 @@ grammar Perl6::Grammar is HLL::Grammar does STD { } else { # Augment. Ensure we can. - if !%*PRAGMAS && $longname.text ne 'Cool' { + if !$/.CURSOR.pragma('MONKEY-TYPING') && $longname.text ne 'Cool' { $/.CURSOR.typed_panic('X::Syntax::Augment::WithoutMonkeyTyping'); } elsif !$longname { @@ -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; # Override this so we can set $*LEFTSIGIL. my $*LEFTSIGIL := ''; my $*IN_RETURN := 0; @@ -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; } @@ -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); diff --git a/src/Perl6/World.nqp b/src/Perl6/World.nqp index c591c94d425..99b4a64a537 100644 --- a/src/Perl6/World.nqp +++ b/src/Perl6/World.nqp @@ -836,11 +836,10 @@ class Perl6::World is HLL::World { } $cursor.define_slang("MAIN", $cursor.WHAT, $actions); $cursor.set_actions($actions); - $cursor.braid."!dump"('add_package_declarator ' ~ $/.Str) if %*PRAGMAS; self.install_lexical_symbol(self.cur_lexpad(), '%?LANG', self.p6ize_recursive(%*LANG)); $*LANG := $cursor; -# self.install_lexical_symbol(self.cur_lexpad(), '$?LANG', $cursor); + $*LEAF := $cursor; } method do_import($/, $handle, $package_source_name, $arglist?) { @@ -917,7 +916,7 @@ class Perl6::World is HLL::World { 'worries', 1, ); - # pragmas without args that just set %*PRAGMAS + # pragmas without args that just set_pragma to true my %just_set_pragma := nqp::hash( 'fatal', 1, 'internals', 1, @@ -960,10 +959,10 @@ class Perl6::World is HLL::World { } if %just_set_pragma{$name} { - %*PRAGMAS{$name} := $on; + $*LANG.set_pragma($name, $on); } elsif $name eq 'MONKEY' { - %*PRAGMAS{$_.key} := $on if nqp::eqat($_.key,'MONKEY',0) for %just_set_pragma; + $*LANG.set_pragma($_.key, $on) if nqp::eqat($_.key,'MONKEY',0) for %just_set_pragma; } elsif $name eq 'strict' { if nqp::islist($arglist) { @@ -974,7 +973,7 @@ class Perl6::World is HLL::World { elsif $name eq 'soft' { # This is an approximation; need to pay attention to # argument list really. - %*PRAGMAS := $on; + $*LANG.set_pragma('soft', $on); } elsif $name eq 'precompilation' { if $on { @@ -1007,11 +1006,12 @@ class Perl6::World is HLL::World { if nqp::istype($value,$Bool) && $value { $type := $arg.key; if $type eq 'D' || $type eq 'U' { - %*PRAGMAS{$name} := $type; + $*LANG.set_pragma($name, $type); next; } elsif $type eq '_' { - nqp::deletekey(%*PRAGMAS,$name); + # XXX shouldn't know this + nqp::deletekey($*LANG.slangs,$name); next; } } @@ -1067,7 +1067,7 @@ class Perl6::World is HLL::World { } # no specific smiley found, check for default - elsif %*PRAGMAS{$pragma} -> $default { + elsif $/.CURSOR.pragma($pragma) -> $default { my class FakeOfType { has $!type; method ast() { $!type } } if $default ne '_' { if $*OFTYPE { @@ -1783,12 +1783,12 @@ class Perl6::World is HLL::World { my $varast := $var.ast; my $name := $varast.name; my $BLOCK := self.cur_lexpad(); - self.handle_OFTYPE_for_pragma($/,'variables'); + self.handle_OFTYPE_for_pragma($var,'variables'); my %cont_info := self.container_type_info(NQPMu, $var, $*OFTYPE ?? [$*OFTYPE.ast] !! [], []); my $descriptor := self.create_container_descriptor(%cont_info, 1, $name); - nqp::die("auto_declare_var") unless nqp::objectid($*PACKAGE) == nqp::objectid($*LANG.package); + nqp::die("auto_declare_var") unless nqp::objectid($*PACKAGE) == nqp::objectid($*LEAF.package); self.install_lexical_container($BLOCK, $name, %cont_info, $descriptor, :scope('our'), :package($*LANG.package)); @@ -1953,7 +1953,7 @@ class Perl6::World is HLL::World { my @params := %signature_info; if $method { - my $package := nqp::istype($/,NQPMu) ?? $*LANG.package !! $/.CURSOR; + my $package := nqp::istype($/,NQPMu) ?? $*LEAF.package !! $/.CURSOR; unless @params[0] { @params.unshift(hash( nominal_type => $invocant_type, @@ -2299,7 +2299,7 @@ class Perl6::World is HLL::World { # If it's a routine, store the package to make backtraces nicer. if nqp::istype($code, $routine_type) { - nqp::die("finish_code_object") unless nqp::objectid($*PACKAGE) == nqp::objectid($*LANG.package); + nqp::die("finish_code_object") unless nqp::objectid($*PACKAGE) == nqp::objectid($*LEAF.package); nqp::bindattr($code, $routine_type, '$!package', $*PACKAGE); } @@ -2866,7 +2866,7 @@ class Perl6::World is HLL::World { # Tries to locate an attribute meta-object; optionally panic right # away if we cannot, otherwise add it to the post-resolution list. method get_attribute_meta_object($/, $name, $later?) { - my $package := nqp::istype($/,NQPMu) ?? $*LANG.package !! $/.CURSOR; + my $package := nqp::istype($/,NQPMu) ?? $*LEAF.package !! $/.CURSOR; unless nqp::can($package.HOW, 'get_attribute_for_usage') { $/.CURSOR.panic("Cannot understand $name in this context"); } @@ -3814,8 +3814,8 @@ class Perl6::World is HLL::World { } } } - nqp::die("find_symbol1") unless nqp::objectid($*PACKAGE) == nqp::objectid($*LANG.package); - $cur-package := $*LANG.package unless $cur-package; + nqp::die("find_symbol1") unless nqp::objectid($*PACKAGE) == nqp::objectid($*LEAF.package); + $cur-package := $*LEAF.package unless $cur-package; if nqp::existskey($cur-package.WHO, $final_name) { return nqp::atkey($cur-package.WHO, $final_name); } @@ -3841,8 +3841,8 @@ class Perl6::World is HLL::World { } } unless $found { - nqp::die("find_symbol2") unless nqp::objectid($*PACKAGE) == nqp::objectid($*LANG.package); - $cur-package := $*LANG.package unless $cur-package; + nqp::die("find_symbol2") unless nqp::objectid($*PACKAGE) == nqp::objectid($*LEAF.package); + $cur-package := $*LEAF.package unless $cur-package; if nqp::existskey($cur-package.WHO, $first) { $result := nqp::atkey($cur-package.WHO, $first); @name := nqp::clone(@name); @@ -4338,7 +4338,7 @@ class Perl6::World is HLL::World { my $ex; my int $nok; try { - my $*LANG := $/.CURSOR; + my $*LEAF := $/.CURSOR; $res := $code(); CATCH { $nok := 1;