Merge pull request #3040 from vrurg/rakudo_3028

Implement support for defining new symbols in CORE.e.setting

Because loading of all CORE settings caused some tests to fail due to the way SETTING and CORE pseudo-packages behaved, this fix also includes improvements to PseudoStash class. Most notable changes are:

    PSEUDO::<missing-symbol> now returns Failure where previously it was Nil. Done so to conform to the way ::() works.

    LEXICAL:: now includes all symbols from scope's lexical chains and dynamic symbols from its caller chain. This conforms to the rule "all symbols visible at location"

    SETTING now includes all symbols from all CORE.settings.

    CORE now includes few additional symbols installed by World.loading_and_symbol_setup. Not sure about them, but seem to be harmless and doesn't affect roast though was breaking rakudo test.

    UNIT now includes all lexicals visible at the unit level.

    Also binding via chained pseudos is now supported:

    my $*foo;
    sub do-bind { CALLERS::<$*foo> := 42 }
    do-bind;
    say $*foo; # 42

    EVAL doesn't load CORE.setting anymore. Effectively, use v6.X inside EVALs is just ingnored. If this approach is not getting re-considered I would suggest making it a X::Language::TooLate exception.

    Also EVAL context now gets !EVAL_MARKsymbol alongside with!UNIT_MARK. It is necessary to allow SETTING` pseudo find the real unit.

    die and fail now work with $! as default. The symbol is been searched in CALLER::LEXICAL:: as S29-context/die.t spectest suggests.

    new sub in CORE: CORE-SETTING-REV. Returns currently active language revision. It's purpose is to support rakudo tests.

    Fixed a hidden bug where request was always installing submodules into its CALLER::MY:: context. The bug was hidden until pseudo-packages started returning Failure for missing symbols.

lib/Test.pm6

@@ -602,6 +602,7 @@ multi sub is-deeply(Mu $got, Mu $expected, $reason = '') is export {
 }
 
 sub throws-like($code, $ex_type, $reason?, *%matcher) is export {
+    my $caller-context = $*THROWS-LIKE-CONTEXT // CALLER::; # Don't guess our caller context, know it!
     subtest {
         plan 2 + %matcher.keys.elems;
         my $msg;
@@ -610,7 +611,7 @@ sub throws-like($code, $ex_type, $reason?, *%matcher) is export {
             $code()
         } else {
             $msg = "'$code' died";
-            EVAL $code, context => CALLER::CALLER::CALLER::CALLER::CALLER::;
+            EVAL $code, context => $caller-context;
         }
         flunk $msg;
         skip 'Code did not die, can not check exception', 1 + %matcher.elems;
@@ -643,6 +644,7 @@ sub throws-like($code, $ex_type, $reason?, *%matcher) is export {
 sub fails-like (
     \test where Callable:D|Str:D, $ex-type, $reason?, *%matcher
 ) is export {
+    my $*THROWS-LIKE-CONTEXT = CALLER::;
     subtest sub {
         plan 2;
         CATCH { default {

src/Perl6/Actions.nqp

@@ -1288,9 +1288,7 @@ class Perl6::Actions is HLL::Actions does STDActions {
             $*W.add_phasers_handling_code($*DECLARAND, $*UNIT);
         }
 
-        # Checks.
-        $*W.assert_stubs_defined($/);
-        $*W.sort_protos();
+        $*W.prep_comp_unit($/);
 
         # Get the block for the unit mainline code.
         my $unit := $*UNIT;
@@ -1462,6 +1460,10 @@ class Perl6::Actions is HLL::Actions does STDActions {
         self.SET_BLOCK_OUTER_CTX($*UNIT_OUTER);
     }
 
+    method lang-version($/) {
+        self.SET_BLOCK_OUTER_CTX($*UNIT_OUTER);
+    }
+
     method statementlist($/) {
         my $past := QAST::Stmts.new( :node($/) );
         if $<statement> {

src/Perl6/ModuleLoader.nqp

@@ -214,21 +214,35 @@ class Perl6::ModuleLoader does Perl6::ModuleLoaderVMConfig {
     }
 
     # Transforms NULL.<release> into CORE.<previous-release>
-    method transform_setting_name ($setting_name) {
-        my $m := $setting_name ~~ /NULL '.' ( <[c..z]> )/;
+    method previous_setting_name ($setting_name, :$base = 'CORE') {
+        my $m := $setting_name ~~ /$base '.' ( <[c..z]> )/;
         if $m {
             my $rev := ~nqp::atpos($m, 0);
             $setting_name := 'CORE' ~ ($rev le 'd' ?? '' !! '.' ~ nqp::chr(nqp::ord($rev) - 1));
         }
         $setting_name
     }
 
+    method transform_setting_name ($setting_name) {
+        return self.previous_setting_name($setting_name, base => 'NULL');
+    }
+
     method load_setting($setting_name) {
         my $setting;
 
         if $setting_name ne 'NULL' {
+            DEBUG("Requested for settings $setting_name") if $DEBUG;
             # XXX TODO: see https://github.com/rakudo/rakudo/issues/2432
             $setting_name := self.transform_setting_name($setting_name);
+
+            # First, pre-load previous setting.
+            my $prev_setting_name := self.previous_setting_name($setting_name);
+            my $prev_setting;
+            # Don't do this for .c which is just CORE.
+            unless nqp::iseq_s($prev_setting_name, $setting_name) {
+                $prev_setting := self.load_setting($prev_setting_name);
+            }
+
             # Unless we already did so, locate and load the setting.
             unless nqp::defined(%settings_loaded{$setting_name}) {
                 DEBUG("Loading settings $setting_name") if $DEBUG;
@@ -240,12 +254,14 @@ class Perl6::ModuleLoader does Perl6::ModuleLoaderVMConfig {
                 my $*MAIN_CTX;
                 my $preserve_global := nqp::ifnull(nqp::gethllsym('perl6', 'GLOBAL'), NQPMu);
                 nqp::scwbdisable();
+                DEBUG("Loading bytecode from $path") if $DEBUG;
                 nqp::loadbytecode($path);
                 nqp::scwbenable();
                 nqp::bindhllsym('perl6', 'GLOBAL', $preserve_global);
                 unless nqp::defined($*MAIN_CTX) {
                     nqp::die("Unable to load setting $setting_name; maybe it is missing a YOU_ARE_HERE?");
                 }
+                nqp::forceouterctx(nqp::ctxcode($*MAIN_CTX), $prev_setting) if nqp::defined($prev_setting);
                 %settings_loaded{$setting_name} := $*MAIN_CTX;
                 DEBUG("Settings $setting_name loaded") if $DEBUG;
             }

src/Perl6/Optimizer.nqp

@@ -27,7 +27,7 @@ my class Symbols {
     # Some interesting scopes.
     has $!GLOBALish;
     has $!UNIT;
-    has $!SETTING;
+    has @!CORES;
 
     # Cached setting lookups.
     has %!SETTING_CACHE;
@@ -56,6 +56,7 @@ my class Symbols {
     }
     method BUILD($compunit) {
         @!block_stack   := [$compunit[0]];
+        @!CORES         := [];
         $!GLOBALish     := $compunit.ann('GLOBALish');
         $!UNIT          := $compunit.ann('UNIT');
         %!SETTING_CACHE := {};
@@ -268,27 +269,30 @@ my class Symbols {
     }
 
     method find_in_setting($symbol) {
-        if !nqp::defined($!SETTING) {
+        if !nqp::elems(@!CORES) {
             my int $i := +@!block_stack;
-            while $i > 0 && !nqp::defined($!SETTING) {
+            while $i > 0 {
                 $i := $i - 1;
                 my $block := @!block_stack[$i];
                 my %sym := $block.symbol("!CORE_MARKER");
                 if +%sym {
-                    $!SETTING := $block;
+                    nqp::push(@!CORES, $block);
                 }
             }
-            if !nqp::defined($!SETTING) {
+            if !nqp::elems(@!CORES) {
                 nqp::die("Optimizer couldn't find CORE while looking for $symbol.");
             }
         } else {
             if nqp::existskey(%!SETTING_CACHE, $symbol) {
                 return %!SETTING_CACHE{$symbol};
             }
         }
-        my %sym := $!SETTING.symbol($symbol);
-        if +%sym {
-            return %!SETTING_CACHE{$symbol} := self.force_value(%sym, $symbol, 1);
+        for @!CORES -> $core {
+            my %sym := $core.symbol($symbol);
+            if +%sym {
+                return %!SETTING_CACHE{$symbol} := self.force_value(%sym, $symbol, 1);
+            }
+
         }
         nqp::die("Optimizer couldn't find $symbol in SETTING.");
     }

src/Perl6/World.nqp

@@ -180,6 +180,9 @@ sub levenshtein_candidate_heuristic(@candidates, $target) {
 
 # This builds upon the HLL::World to add the specifics needed by Rakudo Perl 6.
 class Perl6::World is HLL::World {
+
+    has $!setting_fixup_task;
+
     my class Perl6CompilationContext is HLL::World::CompilationContext {
         # The stack of lexical pads, actually as QAST::Block objects. The
         # outermost frame is at the bottom, the latest frame is on top.
@@ -558,6 +561,11 @@ class Perl6::World is HLL::World {
     # NOTE: Revision .c has special meaning because it doesn't have own dedicated CORE setting and serves as the base
     # for all other revisions.
     method load-lang-ver($ver-match, $comp) {
+        if $*INSIDE-EVAL {
+            # XXX This is desirable behavior. But it breaks some code. Just ignore version change for now.
+            #$ver-match.typed_panic: 'X::Language::TooLate';
+            return
+        }
         $*MAIN   := 'MAIN';
         $*STRICT := 1 if $*begin_compunit;
 
@@ -663,9 +671,10 @@ class Perl6::World is HLL::World {
         }
         else {
             $setting_name := %*COMPILING<%?OPTIONS><setting> // 'CORE';
-            $*COMPILING_CORE_SETTING := 1 if $setting_name eq 'NULL';
-            $*SET_DEFAULT_LANG_VER := 0
-                if nqp::eqat($setting_name, 'NULL', 0);
+            if nqp::eqat($setting_name, 'NULL', 0) {
+                $*COMPILING_CORE_SETTING := 1;
+                $*SET_DEFAULT_LANG_VER := 0;
+            }
             self.load_setting($/,$setting_name);
             $*UNIT.annotate('IN_DECL', 'mainline');
         }
@@ -782,6 +791,12 @@ class Perl6::World is HLL::World {
         }
     }
 
+    method add_unit_marker($/, $name) {
+        my $marker := self.pkg_create_mo($/, $/.how('package'), :$name);
+        $marker.HOW.compose($marker);
+        self.install_lexical_symbol($*UNIT, $name, $marker);
+    }
+
     method mop_up_and_check($/) {
 
         # Install POD-related variables.
@@ -797,9 +812,8 @@ class Perl6::World is HLL::World {
         my $name := $*COMPILING_CORE_SETTING
           ?? '!CORE_MARKER'
           !! '!UNIT_MARKER';
-        my $marker := self.pkg_create_mo($/, $/.how('package'), :$name);
-        $marker.HOW.compose($marker);
-        self.install_lexical_symbol($*UNIT, $name, $marker);
+        self.add_unit_marker($/, $name);
+        self.add_unit_marker($/, '!EVAL_MARKER') if $*INSIDE-EVAL;
 
         # CHECK time.
         self.CHECK();
@@ -898,17 +912,27 @@ class Perl6::World is HLL::World {
         }
     }
 
+    method prep_comp_unit ($/) {
+        self.add_load_dependency_task(:deserialize_ast($!setting_fixup_task), :fixup_ast($!setting_fixup_task));
+        # Checks.
+        self.assert_stubs_defined($/);
+        self.sort_protos();
+    }
+
     # Loads a setting.
     method load_setting($/, $setting_name) {
         # Do nothing for the NULL setting.
+        if $*INSIDE-EVAL {
+            return
+        }
         if $setting_name ne 'NULL' {
             # XXX TODO: see https://github.com/rakudo/rakudo/issues/2432
             $setting_name := Perl6::ModuleLoader.transform_setting_name($setting_name);
             # Load it immediately, so the compile time info is available.
             # Once it's loaded, set it as the outer context of the code
-            # being compiled.
-            my $setting := %*COMPILING<%?OPTIONS><outer_ctx>
-                        := Perl6::ModuleLoader.load_setting($setting_name);
+            # being compiled unless being loaded as another core dependency.
+            my $setting := %*COMPILING<%?OPTIONS><outer_ctx> :=
+                            Perl6::ModuleLoader.load_setting($setting_name);
 
             # Add a fixup and deserialization task also.
             my $fixup := QAST::Stmt.new(
@@ -926,7 +950,8 @@ class Perl6::World is HLL::World {
                     )
                 )
             );
-            self.add_load_dependency_task(:deserialize_ast($fixup), :fixup_ast($fixup));
+            $!setting_fixup_task := $fixup;
+            # self.add_load_dependency_task(:deserialize_ast($fixup), :fixup_ast($fixup));
 
             return nqp::ctxlexpad($setting);
         }
@@ -4782,6 +4807,7 @@ class Perl6::World is HLL::World {
 
         # If it's a single-part name, look through the lexical
         # scopes and try the current package.
+
         if +@name == 1 {
             my str $final_name := ~@name[0];
             if $*WANTEDOUTERBLOCK {

src/core.d/core_prologue.pm6

@@ -1,6 +1,6 @@
 use nqp;
 
-# This dynamic is purely for testing support.
-PROCESS::<$CORE-SETTING-REV> := 'd';
+# This sub is only to support tests.
+sub CORE-SETTING-REV { 'd' };
 
 # vim: ft=perl6 expandtab sw=4

src/core.e/core_prologue.pm6

@@ -1,6 +1,6 @@
 use nqp;
 
-# This dynamic is purely for testing support.
-PROCESS::<$CORE-SETTING-REV> := 'e';
+# This sub is only to support tests.
+sub CORE-SETTING-REV { 'e' }
 
 # vim: ft=perl6 expandtab sw=4

src/core/Failure.pm6

@@ -9,15 +9,15 @@ my class Failure is Nil {
 #?endif
 
     method !SET-SELF($!exception) {
-        $!backtrace = $!exception.backtrace || Backtrace.new(5);
+        $!backtrace = $!exception.backtrace || Backtrace.new(3);
         $!exception.reset-backtrace;
         self
     }
 
     multi method new(Failure:D:) { self!throw }
     multi method new(Failure:U:) {
-        my $stash := CALLER::;
-        my $payload = $stash<$!>.DEFINITE ?? $stash<$!> !! "Failed";
+        my $stash := CALLER::LEXICAL::;
+        my $payload = ($stash<$!>:exists && $stash<$!>.DEFINITE) ?? $stash<$!> !! "Failed";
         nqp::create(self)!SET-SELF(
           $payload ~~ Exception ?? $payload !! X::AdHoc.new(:$payload)
         )
@@ -120,8 +120,8 @@ my class Failure is Nil {
 
 proto sub fail(|) {*};
 multi sub fail(--> Nil) {
-    my $stash := CALLER::;
-    my $payload = $stash<$!>.DEFINITE ?? $stash<$!> !! "Failed";
+    my $stash := CALLER::LEXICAL::;
+    my $payload = ($stash<$!>:exists && $stash<$!>.DEFINITE) ?? $stash<$!> !! "Failed";
 
     my $fail := Failure.new( $payload ~~ Exception
       ?? $payload !! X::AdHoc.new(:$payload));

src/core/ForeignCode.pm6

@@ -55,7 +55,9 @@ proto sub EVAL(
     my $*CTXSAVE; # make sure we don't use the EVAL's MAIN context for the
                   # currently compiling compilation unit
 
-    my $LANG := $context<%?LANG> || CALLERS::<%?LANG>;
+    my $LANG := $context<%?LANG>:exists
+                    ?? $context<%?LANG>
+                    !! (CALLERS::<%?LANG>:exists ?? CALLERS::<%?LANG> !! Nil);
     my $*INSIDE-EVAL = 1;
     my $compiled := $compiler.compile:
         $code,

src/core/Perl.pm6

@@ -13,6 +13,12 @@ class Perl does Systemic {
 
     method DISTROnames { <macosx linux freebsd mswin32 openbsd dragonfly netbsd browser> }
     method KERNELnames { <darwin linux freebsd openbsd netbsd  dragonfly win32 browser>  }
+
+    my %version-cache;
+    method version {
+        my $comp-ver = nqp::p6box_s(nqp::getcomp('perl6').language_version());
+        %version-cache{$comp-ver} //= Version.new($comp-ver);
+    }
 }
 
 # vim: ft=perl6 expandtab sw=4