Disallow compiling modules by file name

The important case always starts with a module name, and it's much simpler if we always start with one.
sorear · Aug 19, 2010 · 94a7784 · 94a7784
1 parent affeabf
commit 94a7784
Show file tree

Hide file tree

Showing 7 changed files with 123 additions and 79 deletions.
diff --git a/Niecza.proj b/Niecza.proj
@@ -27,7 +27,7 @@
     <Target Name="SafeMode" DependsOnTargets="SAFE.dll;WriteVersion"/>
 
     <Target Name="Test" DependsOnTargets="CORE.dll;Test.dll;WriteVersion;PerlTask">
-        <Perl Code="compile(stopafter => 'writecs', lang => 'CORE', main => 1, file => 'test.pl');"/>
+        <Perl Code="compile(stopafter => 'writecs', file => 'test.pl');"/>
         <Csc Sources="obj\MAIN.cs" TargetType="exe" AdditionalLibPaths="obj"
             OutputAssembly="obj\MAIN.exe"
             References="Test.dll;SAFE.dll;CORE.dll;Kernel.dll"/>
@@ -48,19 +48,19 @@
     </Target>
 
     <Target Name="CORE.cs" Inputs="@(CompilerPerl);obj\SAFE.store;lib\CORE.setting" Outputs="obj\CORE.cs;obj\CORE.store" DependsOnTargets="BuildSTD;SAFE.cs;Grammar;PerlTask">
-        <Perl Code="compile(stopafter => 'writecs', lang => 'SAFE', file => 'lib/CORE.setting');"/>
+        <Perl Code="compile(stopafter => 'writecs', lang => 'SAFE', setting => 1, name => 'CORE');"/>
     </Target>
 
     <Target Name="SAFE.cs" Inputs="@(CompilerPerl);lib\SAFE.setting"
         Outputs="obj\SAFE.cs;obj\SAFE.store"
         DependsOnTargets="BuildSTD;Grammar;PerlTask">
-        <Perl Code="compile(stopafter => 'writecs', lang => 'NULL', file => 'lib/SAFE.setting');"/>
+        <Perl Code="compile(stopafter => 'writecs', lang => 'NULL', setting => 1, name => 'SAFE');"/>
     </Target>
 
     <Target Name="Test.cs" Inputs="@(CompilerPerl);obj\CORE.store;lib\Test.pm6"
         Outputs="obj\Test.cs;obj\Test.store"
         DependsOnTargets="CORE.cs;BuildSTD;Grammar;PerlTask">
-        <Perl Code="compile(stopafter => 'writecs', lang => 'CORE', file => 'lib/Test.pm6');"/>
+        <Perl Code="compile(stopafter => 'writecs', name => 'Test');"/>
     </Target>
 
     <Target Name="CORE.dll" Inputs="obj\CORE.cs;obj\SAFE.dll;obj\Kernel.dll" Outputs="obj\CORE.dll" DependsOnTargets="CORE.cs;SAFE.dll;Kernel.dll">

diff --git a/niecza_eval b/niecza_eval
@@ -19,6 +19,7 @@ my $stagestats;
 my $stopafter;
 my $aot;
 my $lang = 'CORE';
+my $setting;
 my $safe;
 
 sub usage {
@@ -28,23 +29,24 @@ niecza -- a command line wrapper for Niecza
 
 usage: niecza -e 'code'      # run a one-liner
    OR: niecza file.pl        # run a program
-   OR: niecza -c File.pm     # precompile a module
+   OR: niecza -c My::Module  # precompile a module
    OR: niecza                # interactive shell
 
 general options:
-   --language=NAME           # select your setting
-   --stage-stats             # detailed timing info
-   --stop-after=STAGE        # stop after STAGE and dump AST
-   --aot                     # run ahead-of-time compiler
-   --safe                    # disable system interaction, implies -L SAFE
+   -L --language=NAME        # select your setting
+      --setting              # precompile target is a setting
+   -v --stage-stats          # detailed timing info
+      --stop-after=STAGE     # stop after STAGE and dump AST
+      --aot                  # run ahead-of-time compiler
+      --safe                 # disable system interaction, implies -L SAFE
 EOM
     exit $ex;
 }
 
 GetOptions('evaluate|e=s' => \@evaluate, 'aot' => \$aot,
         'compile|c' => \$module, 'language|L=s' => \$lang,
         'stage-stats|v' => \$stagestats, 'stop-after=s' => \$stopafter,
-        'safe' => \$safe)
+        'safe' => \$safe, 'setting' => \$setting)
     or usage(\*STDERR, 1);
 
 my $excl = 0;
@@ -57,13 +59,18 @@ if ($excl > 1 || $module && !@ARGV || $safe && ($lang ne 'CORE')) {
 $lang = 'SAFE' if $safe;
 
 sub run {
-    compile(main => !$module, stopafter => $stopafter, aot => $aot,
-        stagetime => $stagestats, lang => $lang, safe => $safe, @_);
+    compile(stopafter => $stopafter, aot => $aot,
+        stagetime => $stagestats, lang => $lang, safe => $safe,
+        setting => $setting, @_);
     system 'mono', CompilerDriver->build_file('MAIN.exe')
-        if !$module && !$stopafter;
+        if !({@_}->{name}) && !$stopafter;
 }
 
-if (@ARGV) {
+if ($module) {
+    for (@ARGV) {
+        run(name => $_);
+    }
+} elsif (@ARGV) {
     require File::Slurp;
     for (@ARGV) {
         run(file => $_);

diff --git a/src/Body.pm b/src/Body.pm
@@ -54,11 +54,10 @@ use CgOp ();
             if ($le->[2] == 1 || $le->[2] == 3) {
                 my $sanname = $le->[0];
                 $sanname =~ s/\W//g;
-                $le->[3] = sprintf "%s.F%d_%d_%s", Unit->csname($::UNITNAME),
-                    $self->uid, $nfields_global++, $sanname;
+                $le->[3] = sprintf "%s.F%d_%d_%s", $::UNITNAME, $self->uid,
+                    $nfields_global++, $sanname;
             } elsif ($le->[2] == 2) {
-                $le->[3] = sprintf "%s.%s_info", Unit->csname($::UNITNAME),
-                    $self->csname;
+                $le->[3] = sprintf "%s.%s_info", $::UNITNAME, $self->csname;
             } else {
                 # TODO generate numbered lookups for clonedvars
             }

diff --git a/src/CompilerDriver.pm b/src/CompilerDriver.pm
@@ -43,12 +43,47 @@ File::Path::make_path($builddir);
 sub build_file { File::Spec->catfile($builddir, $_[1]) }
 
 sub metadata_for {
-    my ($cl, $unit) = @_;
+    my ($unit) = @_;
     $unit =~ s/::/./g;
 
     Storable::retrieve(File::Spec->catfile($builddir, "$unit.store"))
 }
 
+sub get_perl6lib {
+    $libdir, File::Spec->curdir
+}
+
+sub find_module {
+    my $module = shift;
+    my $issetting = shift;
+
+    my @toks = split '::', $module;
+    my $end = pop @toks;
+
+    for my $d (get_perl6lib) {
+        for my $ext (qw( .setting .pm6 .pm )) {
+            next if ($issetting xor ($ext eq '.setting'));
+
+            my $file = File::Spec->catfile($d, @toks, "$end$ext");
+            next unless -f $file;
+
+            if ($ext eq '.pm') {
+                local $/;
+                open my $pm, "<", $file or next;
+                my $pmtx = <$pm>;
+                close $pm;
+                next if $pmtx =~ /^\s*package\s+\w+\s*;/m; # ignore p5 code
+            }
+
+            return $file;
+        }
+    }
+
+    return;
+}
+
+
+
 {
     package
         CursorBase;
@@ -59,23 +94,22 @@ sub metadata_for {
         $::niecza_mod_symbols = $all;
     }
 
-    sub sys_get_perl6lib {
-        $libdir, File::Spec->curdir
-    }
-
     sub sys_load_modinfo {
         my $self = shift;
         my $module = shift;
-        $module =~ s/::/./g;
-
-        my ($symlfile) = File::Spec->catfile($builddir, "$module.store");
-        my ($modfile) = $self->sys_find_module($module, 0)
-            or return undef;
-
-        unless (-f $symlfile and -M $modfile > -M $symlfile) {
-            $self->sys_compile_module($module, $symlfile, $modfile);
-        }
-        return Storable::retrieve($symlfile)->{'syml'};
+        return CompilerDriver::metadata_for($module)->{'syml'};
+        #$module =~ s/::/./g;
+
+        #my ($symlfile) = File::Spec->catfile($builddir, "$module.store");
+        #my ($modfile) = CompilerDriver::find_module($module, 0) or do {
+        #    $self->sorry("Cannot locate module $module");
+        #    return undef;
+        #};
+
+        #unless (-f $symlfile and -M $modfile > -M $symlfile) {
+        #    $self->sys_compile_module($module, $symlfile, $modfile);
+        #}
+        #return CompilerDriver::metadata_for($symlfile)->{'syml'};
     }
 
     sub load_lex {
@@ -104,46 +138,54 @@ sub metadata_for {
 
 sub compile {
     my %args = @_;
-    $args{lang} //= 'CORE';
+
+    my ($name, $file, $code, $lang, $safe, $setting) =
+        @args{'name', 'file', 'code', 'lang', 'safe', 'setting'};
+
+    $lang //= 'CORE';
+
+    if (defined($name) + defined($file) + defined($code) != 1) {
+        Carp::croak("Exactly one of name, file, and code must be used");
+    }
+
+    my $path = $file;
+    if (defined($name)) {
+        $path = find_module($name, $setting);
+        if (!defined($path)) {
+            Carp::croak("Module $name not found");
+        }
+    }
 
     local %::UNITREFS;
+    local %::UNITREFSTRANS;
     local %::UNITDEPSTRANS;
     local $::SETTING_RESUME;
     local $::niecza_mod_symbols;
     local $::YOU_WERE_HERE;
-    local $::UNITNAME = $args{main} ? '' : $args{file};
-    local $::SAFEMODE = $args{safe};
-    $::UNITNAME =~ s/\.(?:pm6?|setting)//;
-    $::UNITNAME =~ s|[\\/]|.|g;
-    $::UNITNAME =~ s|lib\.||; # XXX
+    local $::UNITNAME = $name // 'MAIN';
+    $::UNITNAME =~ s/::/./g;
+    local $::SAFEMODE = $safe;
     $STD::ALL = {};
 
-    if ($::UNITNAME && !defined($args{file})) {
-        Carp::croak("Evals cannot be modules");
-    }
-
-    $::SETTING_RESUME = CompilerDriver->metadata_for($args{lang})->{setting}
-        unless $args{lang} eq 'NULL';
-    $::UNITREFS{$args{lang}} = 1 if $args{lang} ne 'NULL';
-
-    my $time = $args{file} ? ((stat $args{file})[9]) : 0;
+    $::SETTING_RESUME = metadata_for($lang)->{setting} unless $lang eq 'NULL';
+    $::UNITREFS{$lang} = 1 if $lang ne 'NULL';
 
-    if ($::UNITNAME) {
-        $::UNITDEPSTRANS{$::UNITNAME} = [ Cwd::realpath($args{file}), $time ];
+    if (defined($name)) {
+        my $rp = Cwd::realpath($path);
+        $::UNITDEPSTRANS{$name} = [ $rp, ((stat $rp)[9]) ];
     }
 
-    my ($m, $a) = $args{file} ? ('parsefile', $args{file}) :
-        ('parse', $args{code});
+    my ($m, $a) = defined($path) ? (parsefile => $path) : (parse => $code);
 
     my $ast;
-    my $basename = $::UNITNAME || 'MAIN';
+    my $basename = $::UNITNAME;
     my $csfile = File::Spec->catfile($builddir, "$basename.cs");
-    my $outname = File::Spec->catfile($builddir,
+    my $outfile = File::Spec->catfile($builddir,
         $basename . ($args{main} ? ".exe" : ".dll"));
 
     my @phases = (
         [ 'parse', sub {
-            $ast = Niecza::Grammar->$m($a, setting => $args{lang},
+            $ast = Niecza::Grammar->$m($a, setting => $lang,
                 actions => 'Niecza::Actions')->{_ast}; } ],
         [ 'lift_decls', sub {
             $::SETTING_RESUME = undef;
@@ -165,10 +207,11 @@ using Niecza;
 EOH
             $ast->write;
             close ::NIECZA_OUT;
-            if ($::UNITNAME) {
+            if (defined $name) {
                 my $blk = { setting => $::SETTING_RESUME,
                             deps    => \%::UNITDEPSTRANS,
                             refs    => \%::UNITREFS,
+                            trefs   => \%::UNITREFSTRANS,
                             syml    => $::niecza_mod_symbols };
                 store $blk, File::Spec->catfile($builddir, "$basename.store");
             }
@@ -180,13 +223,13 @@ EOH
                 ($args{main} ? () : ("/target:library")),
                 "/lib:$builddir",
                 "/r:Kernel.dll", (map { "/r:$_.dll" } sort keys %::UNITREFS),
-                "/out:$outname",
+                "/out:$outfile",
                 $csfile);
             print STDERR "@args\n" if $args{stagetime};
             system @args;
         } ],
         [ 'aot', sub {
-            system "mono", "--aot", $outname;
+            system "mono", "--aot", $outfile;
         } ]);
 
     for my $p (@phases) {

diff --git a/src/Decl.pm b/src/Decl.pm
@@ -229,7 +229,6 @@ use CgOp;
 
         $::SETTING_RESUME = $body->scopetree;
         my $n = $self->unitname;
-        $n =~ s/::/./g;
 
         CgOp::rawsset($n . '.Environment', CgOp::letvar('protopad'));
     }
@@ -482,7 +481,7 @@ use CgOp;
 
     sub preinit_code {
         my ($self, $body) = @_;
-        my $scope = CompilerDriver->metadata_for($self->unit)->{setting};
+        my $scope = CompilerDriver::metadata_for($self->unit)->{setting};
 
         CodeGen->know_module($self->unit);
         CgOp::prog(

diff --git a/src/Niecza/Actions.pm b/src/Niecza/Actions.pm
@@ -1827,9 +1827,11 @@ sub statement_control__S_use { my ($cl, $M) = @_;
         return;
     }
 
-    my $meta = CompilerDriver->metadata_for($name);
+    my $meta = CompilerDriver::metadata_for($name);
     $::UNITREFS{$name} = 1;
+    $::UNITREFSTRANS{$name} = 1;
     %::UNITDEPSTRANS = (%::UNITDEPSTRANS, %{ $meta->{deps} });
+    %::UNITREFSTRANS = (%::UNITREFSTRANS, %{ $meta->{trefs} });
     my %symbols;
     $symbols{$name} = [ $name ];
     $symbols{$name . '::'} = [ $name . '::' ];
@@ -2165,7 +2167,7 @@ sub comp_unit { my ($cl, $M) = @_;
     my $body;
     my $sl = $M->{statementlist}{_ast};
 
-    if (!$::YOU_WERE_HERE && $::UNITNAME) {
+    if (!$::YOU_WERE_HERE && $::UNITNAME ne 'MAIN') {
         $sl = Op::StatementList->new(node($M), children => [ $sl,
                 Op::YouAreHere->new(save_only => 1, unitname => $::UNITNAME)]);
     }
@@ -2185,10 +2187,11 @@ sub comp_unit { my ($cl, $M) = @_;
                     var => $cl->gensym, body => $body)]));
     }
 
+    my $sn = $::SETTINGNAME; $sn =~ s/::/./g;
     $M->{_ast} = Unit->new(mainline => $body, name => $::UNITNAME,
         ($::SETTING_RESUME ? (setting => $::SETTING_RESUME) : ()),
         is_setting => (!!$::YOU_WERE_HERE),
-        setting_name => $::SETTINGNAME);
+        setting_name => $sn);
 }
 
 1;