Browse files

Redo build system; bootstrapped niecza is live

  • Loading branch information...
1 parent 56c80b0 commit 923eae547a2199532226515536ab987c9266b0dd @sorear committed Jan 14, 2011
Showing with 135 additions and 8,918 deletions.
  1. +2 −0 .gitignore
  2. +1 −0 FETCH_URL
  3. +40 −0 Makefile
  4. +0 −95 Niecza.proj
  5. +0 −19 PerlStub.pl
  6. +0 −79 PerlTask.cs
  7. +23 −31 TODO
  8. +0 −86 niecza
  9. +0 −91 niecza_eval
  10. +0 −47 src/Body.pm
  11. 0 {v6 → src}/Body.pm6
  12. +0 −111 src/CClass.pm
  13. 0 {v6 → src}/CClass.pm6
  14. +0 −138 src/CgOp.pm
  15. 0 {v6 → src}/CgOp.pm6
  16. +0 −288 src/CompilerDriver.pm
  17. +0 −1,320 src/Metamodel.pm
  18. 0 {v6 → src}/Metamodel.pm6
  19. +0 −332 src/NAMBackend.pm
  20. 0 {v6 → src}/NAME.pm6
  21. 0 {v6 → src}/NAMOutput.pm6
  22. +0 −16 src/NAMWriter.pm
  23. +0 −2,864 src/Niecza/Actions.pm
  24. +0 −12 src/Niecza/Backend/CLisp.pm
  25. +0 −29 src/Niecza/Backend/Mono.pm
  26. +0 −13 src/Niecza/Backend/NAM.pm
  27. +0 −22 src/Niecza/Compiler.pm
  28. +0 −17 src/Niecza/Frontend/STD.pm
  29. +0 −45 src/Niecza/Grammar.pm6
  30. +0 −12 src/Niecza/Pass/Backend.pm
  31. +0 −13 src/Niecza/Pass/Begin.pm
  32. +0 −9 src/Niecza/Pass/Beta.pm
  33. +0 −9 src/Niecza/Pass/Simplifier.pm
  34. +0 −59 src/Niecza/Simple.pm
  35. 0 {v6 → src}/NieczaActions.pm6
  36. 0 {v6 → src}/NieczaBackendClisp.pm6
  37. 0 {v6 → src}/NieczaBackendDotnet.pm6
  38. 0 {v6 → src}/NieczaBackendNAM.pm6
  39. 0 {v6 → src}/NieczaCompiler.pm6
  40. 0 {v6 → src}/NieczaFrontendSTD.pm6
  41. 0 {v6 → src}/NieczaGrammar.pm6
  42. 0 {v6 → src}/NieczaPassBegin.pm6
  43. 0 {v6 → src}/NieczaPassBeta.pm6
  44. 0 {v6 → src}/NieczaPassSimplifier.pm6
  45. 0 {v6 → src}/NieczaPathSearch.pm6
  46. +0 −1,285 src/Op.pm
  47. 0 {v6 → src}/Op.pm6
  48. +0 −8 src/Op/Helpers.pm
  49. 0 {v6 → src}/OptRxSimple.pm6
  50. +0 −134 src/Optimizer/Beta.pm
  51. +0 −219 src/Optimizer/RxSimple.pm
  52. +0 −169 src/Optimizer/Simplifier.pm
  53. +0 −1,031 src/RxOp.pm
  54. 0 {v6 → src}/RxOp.pm6
  55. 0 {v6 → src}/STD.pm6
  56. +0 −109 src/Sig.pm
  57. 0 {v6 → src}/Sig.pm6
  58. 0 {v6 → src}/Stash.pm6
  59. +0 −17 src/Unit.pm
  60. 0 {v6 → src}/Unit.pm6
  61. +1 −1 v6/harness → src/niecza
  62. 0 {v6 → src}/tryfile
  63. +68 −45 t/cclass.t
  64. 0 {v6 → t}/cgop.t
  65. +0 −10 v6/README
  66. +0 −10 v6/RUN.pl
  67. +0 −23 v6/TODO
  68. +0 −90 v6/cclass.t
  69. +0 −4 v6/package
  70. +0 −6 v6/rebuild
View
2 .gitignore
@@ -9,5 +9,7 @@ v6/STD.errors
*.mdb
*.exe
core
+boot
perf/profile.txt
perf/xdb.il
+.fetch-stamp
View
1 FETCH_URL
@@ -0,0 +1 @@
+https://github.com/downloads/sorear/niecza/niecza-1.5.zip
View
40 Makefile
@@ -0,0 +1,40 @@
+### CONFIGURATION
+
+# How to run CLR programs; can be blank for Win32
+RUN_CLR=mono
+CSC=gmcs
+RM=rm -f
+CP=cp
+
+cskernel=Kernel.cs Builtins.cs Cursor.cs JSYNC.cs NieczaCLR.cs
+csbackend=CLRBackend.cs
+
+# keep this in dependency order
+units=SAFE CORE CClass Body Unit CgOp Op Sig RxOp NAME Stash JSYNC STD \
+ NieczaGrammar Metamodel OptRxSimple NAMOutput NieczaActions \
+ NieczaFrontendSTD NieczaPassBegin NieczaPassBeta NieczaPassSimplifier \
+ NieczaPathSearch NieczaBackendNAM NieczaBackendDotnet NieczaBackendClisp \
+ NieczaCompiler
+
+all: obj/Kernel.dll obj/CLRBackend.exe .fetch-stamp
+ cd src && $(RUN_CLR) ../boot/run/Niecza.exe -I../lib -v -c -Bnam niecza
+ for nfile in $(units); do echo $$nfile; \
+ $(RUN_CLR) boot/obj/CLRBackend.exe boot/obj $$nfile.nam $$nfile.dll 0; \
+ done
+ $(RUN_CLR) boot/obj/CLRBackend.exe boot/obj MAIN.nam MAIN.exe 1
+ $(CP) $(patsubst %,boot/obj/%.dll,Kernel $(units)) run/
+ $(CP) boot/obj/MAIN.exe run/Niecza.exe
+
+.fetch-stamp: FETCH_URL
+ -rm -rf boot/
+ mkdir boot
+ wget --no-check-certificate -Oboot/niecza.zip $$(cat FETCH_URL)
+ cd boot && unzip niecza.zip
+ touch .fetch-stamp
+
+obj/Kernel.dll: $(patsubst %,lib/%,$(cskernel))
+ $(CSC) /target:library /out:obj/Kernel.dll /unsafe+ \
+ $(patsubst %,lib/%,$(cskernel))
+obj/CLRBackend.exe: $(patsubst %,lib/%,$(csbackend)) obj/Kernel.dll
+ $(CSC) /target:exe /lib:obj /out:obj/CLRBackend.exe /r:Kernel.dll \
+ $(patsubst %,lib/%,$(csbackend))
View
95 Niecza.proj
@@ -1,95 +0,0 @@
-<Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"
- ToolsVersion="2.0">
- <UsingTask TaskName="Perl" AssemblyFile="obj\PerlTask.dll"/>
- <PropertyGroup>
- <!-- Tool paths -->
- <Subversion>svn</Subversion>
- <Make>make</Make>
- <Perl>perl</Perl>
-
- <!-- Other centralized variables -->
- <SpecTestUrl>http://svn.pugscode.org/pugs/t/spec</SpecTestUrl>
-
- <!-- infrastructure -->
- <SpecTest_existed Condition="Exists('t/spec')">Y</SpecTest_existed>
- </PropertyGroup>
-
- <ItemGroup>
- <CompilerPerl Include="src\Op\Helpers.pm;src\CClass.pm;src\Op.pm;src\NAMWriter.pm;src\Niecza\Pass\Begin.pm;src\Niecza\Pass\Beta.pm;src\Niecza\Pass\Backend.pm;src\Niecza\Pass\Simplifier.pm;src\Niecza\Backend\CLisp.pm;src\Niecza\Backend\NAM.pm;src\Niecza\Backend\Mono.pm;src\Niecza\Actions.pm;src\Niecza\Grammar.pmc;src\Niecza\Frontend\STD.pm;src\Niecza\Simple.pm;src\Niecza\Compiler.pm;src\Body.pm;src\CgOp.pm;src\Sig.pm;src\Optimizer\Beta.pm;src\Optimizer\Simplifier.pm;src\Optimizer\RxSimple.pm;src\Metamodel.pm;src\NAMBackend.pm;src\RxOp.pm;src\Unit.pm;src\CompilerDriver.pm"/>
- <RTS Include="lib\Kernel.cs;lib\JSYNC.cs;lib\Cursor.cs;lib\Builtins.cs;lib\NieczaCLR.cs"/>
- </ItemGroup>
-
- <!-- Meta targets -->
- <Target Name="Default" DependsOnTargets="CORE.dll;WriteVersion"/>
-
- <Target Name="SafeMode" DependsOnTargets="SAFE.dll;WriteVersion"/>
-
- <Target Name="Test" DependsOnTargets="CORE.dll;Test.dll;WriteVersion;PerlTask">
- <Perl Code="compile(stopafter => 'writenam', file => 'test.pl');"/>
- <Exec Command="mono obj/CLRBackend.exe obj MAIN.nam MAIN.exe 1"/>
- <Exec Command="prove -e mono obj/MAIN.exe"/>
- </Target>
-
- <Target Name="WriteVersion">
- <Exec Command="git describe --tags &gt; VERSION"/>
- </Target>
-
- <!-- Libraries -->
- <Target Name="Kernel.dll" Inputs="@(RTS)" Outputs="obj\Kernel.dll">
- <Csc Sources="@(RTS)" TargetType="library"
- OutputAssembly="obj\Kernel.dll" EmitDebugInformation="true"
- AllowUnsafeBlocks="true"/>
- </Target>
-
- <Target Name="CLRBackend.exe" DependsOnTargets="Kernel.dll"
- Inputs="obj\Kernel.dll;lib\CLRBackend.cs" Outputs="obj\CLRBackend.exe">
- <Csc Sources="lib\CLRBackend.cs" TargetType="exe"
- References="Kernel.dll" OutputAssembly="obj\CLRBackend.exe"
- EmitDebugInformation="true" AdditionalLibPaths="obj"/>
- </Target>
-
- <Target Name="CORE.nam" Inputs="@(CompilerPerl);obj\SAFE.nam;lib\CORE.setting" Outputs="obj\CORE.nam" DependsOnTargets="SAFE.nam;Grammar;PerlTask">
- <Perl Code="compile(stopafter => 'writenam', lang => 'SAFE', setting => 1, name => 'CORE');"/>
- </Target>
-
- <Target Name="SAFE.nam" Inputs="@(CompilerPerl);lib\SAFE.setting"
- Outputs="obj\SAFE.nam" DependsOnTargets="Grammar;PerlTask">
- <Perl Code="compile(stopafter => 'writenam', lang => 'NULL', setting => 1, name => 'SAFE');"/>
- </Target>
-
- <Target Name="Test.nam" Inputs="@(CompilerPerl);obj\CORE.nam;lib\Test.pm6"
- Outputs="obj\Test.nam" DependsOnTargets="CORE.nam;Grammar;PerlTask">
- <Perl Code="compile(stopafter => 'writenam', name => 'Test');"/>
- </Target>
-
- <Target Name="CORE.dll" Inputs="obj\CORE.nam;obj\SAFE.dll;obj\Kernel.dll" Outputs="obj\CORE.dll" DependsOnTargets="CORE.nam;SAFE.dll;Kernel.dll">
- <Exec Command="mono obj/CLRBackend.exe obj CORE.nam CORE.dll 0"/>
- </Target>
-
- <Target Name="SAFE.dll" Inputs="obj\SAFE.nam;obj\Kernel.dll"
- Outputs="obj\SAFE.dll" DependsOnTargets="SAFE.nam;Kernel.dll;CLRBackend.exe">
- <Exec Command="mono obj/CLRBackend.exe obj SAFE.nam SAFE.dll 0"/>
- </Target>
-
- <Target Name="Test.dll" Inputs="obj\Test.nam;obj\CORE.dll;obj\Kernel.dll" Outputs="obj\Test.dll" DependsOnTargets="Test.nam;CORE.dll;Kernel.dll">
- <Exec Command="mono obj/CLRBackend.exe obj Test.nam Test.dll 0"/>
- </Target>
-
- <!-- Proper compiler bits -->
- <Target Name="Grammar" Inputs="src\Niecza\Grammar.pm6" Outputs="src\Niecza\Grammar.pmc">
- <Exec Command="viv --noperl6lib -5 -o src/Niecza/Grammar.pmc src/Niecza/Grammar.pm6"/>
- </Target>
-
- <Target Name="CheckoutSpecTest">
- <Exec Condition="$(SpecTest_existed) != 'Y'"
- Command="$(Subversion) checkout $(SpecTestUrl) t/spec"/>
- <Exec Condition="$(STD_existed) == 'Y'"
- Command="$(Subversion) update t/spec"/>
- </Target>
-
- <Target Name="PerlTask" Inputs="PerlTask.cs" Outputs="obj\PerlTask.dll">
- <Csc Sources="PerlTask.cs" TargetType="library"
- OutputAssembly="obj\PerlTask.dll"
- References="Microsoft.Build.Framework.dll;Microsoft.Build.Utilities.dll"/>
- </Target>
-</Project>
View
19 PerlStub.pl
@@ -1,19 +0,0 @@
-use strict; use warnings;
-open my $realstderr, ">&STDERR";
-open STDERR, ">&STDOUT";
-
-use lib 'src';
-
-while(1) {
- my $line = <STDIN>;
- require CompilerDriver;
- CompilerDriver->import(':all');
- last unless defined($line) && length($line);
- eval $line;
- if ($@) {
- print $@;
- syswrite $realstderr, 'E';
- } else {
- syswrite $realstderr, 'R';
- }
-}
View
79 PerlTask.cs
@@ -1,79 +0,0 @@
-using System;
-using System.IO;
-using System.Diagnostics;
-using Microsoft.Build.Utilities;
-using Microsoft.Build.Framework;
-
-public class PerlInterpreter
-{
- private Process p;
-
- public PerlInterpreter(string perlPath)
- {
- p = new Process();
- p.StartInfo.FileName = perlPath;
- p.StartInfo.Arguments = "PerlStub.pl";
- p.StartInfo.UseShellExecute = false;
- p.StartInfo.RedirectStandardInput = true;
- p.StartInfo.RedirectStandardError = true;
- p.StartInfo.CreateNoWindow = true;
- p.Start();
- }
-
- public bool RunPerl(string code)
- {
- p.StandardInput.WriteLine(code);
- p.StandardInput.Flush();
- int rt = p.StandardError.Read();
- if (rt < 0)
- throw new Exception("Perl interpreter process unexpectedly quit");
- return rt == (int)'R';
- }
-
- private static string FindInterpreter(string basename)
- {
- string pathvar = Environment.GetEnvironmentVariable("PATH") ?? ".";
- foreach (string pel in pathvar.Split(Path.PathSeparator)) {
- string n1 = Path.Combine(pel, basename);
- if (File.Exists(n1)) return n1;
- string n2 = Path.Combine(pel, basename + ".exe");
- if (File.Exists(n2)) return n2;
- }
- throw new Exception("Cannot find " + basename + " in PATH");
- }
-
- private static PerlInterpreter sharedInstance;
- public static PerlInterpreter SharedInstance(string path)
- {
- if (sharedInstance == null)
- sharedInstance = new PerlInterpreter(FindInterpreter(path));
- return sharedInstance;
- }
-}
-
-namespace Niecza.Tasks
-{
- public class Perl : Task
- {
- private string code;
- private string path = "perl";
-
- public override bool Execute()
- {
- return PerlInterpreter.SharedInstance(path).RunPerl(code);
- }
-
- [Required]
- public string Code
- {
- get { return code; }
- set { code = value; }
- }
-
- public string InterpreterPath
- {
- get { return path; }
- set { path = value; }
- }
- }
-}
View
54 TODO
@@ -1,36 +1,28 @@
-New lists: (a little dated, see newlist.pl)
- s/Iterator/IterationCursor/
- .iterator should return a real List (maybe even a primitive something)
- a List itself represents an iteration state
- Lists with no iterators are treated as a fast path in a lot of cases
- possibly, Lists should be limited to one iterator
- $!flat is completely wrong and should die. .flat is just a map-like operator
+From the v6/TODO:
+These things were noticed during translation, but to fix them now would
+only slow me down...
-Niecza-NAM-Lorito:
- NAM is a Lorito prototype! See #parrot logs
- To make it real:
- * 3-operand code
- * Deregisterization pass infers use of CLR stack when registers have nested live ranges and are used exactly once
- * Types and ops can be provided by a library binding spec; var, fetch et al come from niecza-perl6 library binding. As does the entire object model and subcall - bare NAM-Lorito probably won't have sub support.
- * NAM has a wire format resembling LASM
- * NAM needs to have real continuations
-
-needlib 'foo'
-
-const int 'a'
-var str 'b'
-
-code 'main' {
- op 1, 2, 3
-}
-
-blob {
- 'a' = 1
- 'b' = 'Hello, world'
-}
+* sprintf, in particular, the ability to make numbers hex
+* hash initialization idioms don't work
+* no qw< >
+* Any strificatrion/numification warnings would be useful
+* no is rw on attributes and methods
+* &split
+* &callsame
+* BUILD
+* given/when
+* non-$ attributes; @.foo and @<foo>
+* :$.foo is broken
+* eager map optimizations
+* return()
+* stashes should be accessed as common values
+* "Action method ::($name) not implemented", also needs $<sym>
+* context accelerators need to robustly handle undefined objects
+* .list, item as accelerated contexts
+* explicitly imprecise error reporting - lines A-B
+* @PROCESS::ARGS ::= [1,2,3]; ok +[ @*ARGS ] == 3 # Bug
+* Whatever-currying of prefixes my $x = ~*; say $x() # Whatever()<instance>
Other stuff
- * Write a LHF file
* Write a ROADMAP
* Flesh out documentation a lot
- * $*IN.slurp needs to use Console.OpenStdOutput (mike_f++)
View
86 niecza
@@ -1,86 +0,0 @@
-#! /usr/bin/env perl
-use strict;
-use warnings;
-use Getopt::Long qw(GetOptionsFromArray);
-use utf8;
-use v5.10;
-use File::Basename;
-use File::Slurp qw(slurp);
-use Encode;
-
-use lib 'src';
-use Niecza::Simple;
-
-
-# print the help message
-sub help {
-print <<'HELP';
-Usage: niecza [switches] [--] [programfile] [arguments]
- -B<backend> execute using the <backend> backend
- -C<backend> compile using the <backend> backend
- (valid backends are: clisp,mono)
- -F<frontend> use the <frontend> frontend
- (valid frontends are: STD)
- -e
- -o <file> Place the output into <file>
-HELP
-exit;
-}
-
-# get command line options
-my ($C,$B,$F,$help,$e,$output);
-my @args;
-my %args;
-my $subsystem;
-my $level;
-for (@ARGV) {
- if (/\+\+ (\+*) (\w+)/x) {
- $level = $1;
- $subsystem = $2;
- $args{$subsystem} = [];
- } elsif ($subsystem && /\+\+ \Q$level\E \/ \Q$subsystem\E/x) {
- $level = $subsystem = undef;
- } elsif ($subsystem) {
- push(@{$args{$subsystem}},$_);
- } else {
- push(@args,$_);
- }
-}
-Getopt::Long::Configure(qw(bundling no_ignore_case pass_through require_order));
-GetOptionsFromArray(
- \@args,
- "C=s" => \$C,
- "B=s" => \$B,
- "F=s" => \$F,
- 'h|help' => \$help,
- 'e=s' => \$e,
- 'o=s' => \$output
-) || help;
-help if $help;
-
-
-my $backend = $B // $C // 'mono';
-my $compiler = Niecza::Simple::create_compiler(backend=>$backend);
-
-my $source;
-my $filename;
-if ($e) {
- $source = $e;
- $filename = '-e';
-} elsif (!@args) {
- die "no input file";
-} else {
- $filename = shift(@args);
- $source = slurp($filename);
-}
-
-if ($C and $B) {
- die "You can't specify both -C and -B.\n";
-}
-
-if ($C) {
- $compiler->compile(source=>$source,filename=>$filename,output=>$output);
-} else {
- $compiler->run(source=>decode('utf-8',$source),filename=>$filename);
-}
-
View
91 niecza_eval
@@ -1,91 +0,0 @@
-#! /usr/bin/env perl
-use warnings;
-use strict;
-use 5.010;
-
-BEGIN {
- use FindBin;
- use File::Spec;
- unshift @INC, File::Spec->catdir($FindBin::RealBin, "src");
-}
-
-use CompilerDriver ':all';
-use Getopt::Long;
-use autodie ':all';
-
-my @evaluate;
-my $module;
-my $stagestats;
-my $stopafter;
-my $aot;
-my $lang = 'CORE';
-my $setting;
-my $safe;
-
-sub usage {
- my ($fh, $ex) = @_;
- print $fh <<EOM;
-niecza -- a command line wrapper for Niecza
-
-usage: niecza -e 'code' # run a one-liner
- OR: niecza file.pl [args] # run a program
- OR: niecza -c My::Module # precompile a module
- OR: niecza # interactive shell
-
-general options:
- -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, 'setting' => \$setting)
- or usage(\*STDERR, 1);
-
-my $excl = 0;
-$excl++ if @evaluate;
-$excl++ if @ARGV;
-if ($excl > 1 || $module && !@ARGV || $safe && ($lang ne 'CORE')) {
- usage(\*STDERR, 1);
-}
-
-$lang = 'SAFE' if $safe;
-
-sub run {
- compile(stopafter => $stopafter, aot => $aot,
- stagetime => $stagestats, lang => $lang, safe => $safe,
- setting => $setting, @_);
- system 'mono', CompilerDriver::build_file('MAIN.exe'), @ARGV
- if !({@_}->{name}) && !$stopafter;
-}
-
-if ($module) {
- for (@ARGV) {
- run(name => $_);
- }
-} elsif (@ARGV) {
- require File::Slurp;
- run(file => shift(@ARGV));
-} elsif (@evaluate) {
- for (@evaluate) {
- run(code => $_);
- }
-} else {
- require Term::ReadLine;
- my $term = Term::ReadLine->new('niecza');
- while (defined ($_ = $term->readline("> ")) ) {
- /^\s*[^\s#]/ or next;
- eval {
- run(code => "say ($_)");
- };
- say $@ if $@;
- $term->addhistory($_) if /\S/;
- }
-}
View
47 src/Body.pm
@@ -1,47 +0,0 @@
-use strict;
-use warnings;
-use 5.010;
-use utf8;
-use CgOp ();
-
-# NOTE: most of this is dead. The real Body is Metamodel::StaticSub
-
-{
- package Body;
- use Moose;
-
- has name => (isa => 'Str', is => 'rw', default => "ANON");
- has uid => (isa => 'Int', is => 'ro', default => sub { ++(state $i) });
- has do => (isa => 'Op', is => 'rw');
- has signature => (isa => 'Maybe[Sig]', is => 'rw');
- has mainline => (isa => 'Bool', is => 'ro', lazy => 1,
- builder => 'is_mainline');
- # voidbare, init, end, regex are still used; see Metamodel.pm
- # this field is on the way out
- has type => (isa => 'Str', is => 'rw');
- has returnable=> (isa => 'Bool', is => 'rw');
-
- # my $x inside, floats out; mostly for blasts; set by context so must be rw
- has transparent => (isa => 'Bool', is => 'rw', default => 0);
- # only used for the top mainline
- has file => (isa => 'Str', is => 'ro');
- has text => (isa => 'Str', is => 'ro');
-
- # metadata for runtime inspection
- has class => (isa => 'Str', is => 'rw', default => 'Sub');
- has ltm => (is => 'rw');
-
- sub is_mainline { $_[0]->scopetree->{'?is_mainline'} }
-
- sub csname {
- my ($self) = @_;
- my @name = split /\W+/, $self->name;
- shift @name if @name && $name[0] eq '';
- join("", (map { ucfirst $_ } @name), "_", $self->uid, "C");
- }
-
- __PACKAGE__->meta->make_immutable;
- no Moose;
-}
-
-1;
View
0 v6/Body.pm6 → src/Body.pm6
File renamed without changes.
View
111 src/CClass.pm
@@ -1,111 +0,0 @@
-use 5.010;
-use strict;
-use warnings;
-use utf8;
-
-package CClass;
-
-our %Gc = (map { $_ => ((state $i)++) } qw/ Lu Ll Lt Lm Lo
- Mn Ms Me Nd Nl No Zs Zl Zp Cc Cf Cs Co Pc Pd Ps Pc Pi Pf Po Sm
- Sc Sk So Cn /);
-
-our $Empty = bless [ ], 'CClass';
-our $Full = bless [ 0, 0x3FFF_FFFF ], 'CClass';
-
-sub range {
- my ($cl, $c1, $c2) = @_;
-
- return $Empty if $c1 gt $c2;
-
- bless [ ord($c1), 0x3FFF_FFFF, ord($c2) + 1, 0 ], $cl;
-}
-
-sub enum {
- my ($cl, @cs) = @_;
- my $ch = $Empty;
-
- for (@cs) {
- $ch = $ch->plus($_);
- }
-
- $ch;
-}
-
-sub catm {
- my ($cl, @bits) = @_;
- my $m = 0;
- for (@bits) {
- $m |= 1 << $Gc{$_};
- }
- $m ? (bless [ 0, $m ], $cl) : $Empty;
-}
-
-sub _binop {
- my ($func, $al, $bl) = @_;
- $bl = CClass->range($bl, $bl) if !ref($bl);
- my ($alix, $alcur) = (0, 0);
- my ($blix, $blcur) = (0, 0);
- my @o;
- my $pos = 0;
- my $ocur = $func->(0, 0);
- if ($ocur != 0) {
- push @o, 0, $ocur;
- }
-
- while ($pos != 1e7) {
- my $ata = $alix < @$al && $al->[$alix] == $pos;
- my $atb = $blix < @$bl && $bl->[$blix] == $pos;
-
- if ($ata) {
- $alcur = $al->[$alix+1];
- $alix += 2;
- }
-
- if ($atb) {
- $blcur = $bl->[$blix+1];
- $blix += 2;
- }
-
- my $onew = $func->($alcur, $blcur);
- if ($onew != $ocur) {
- push @o, $pos, $onew;
- $ocur = $onew;
- }
-
- my $toa = $alix < @$al ? $al->[$alix] : 1e7;
- my $tob = $blix < @$bl ? $bl->[$blix] : 1e7;
-
- $pos = ($toa < $tob) ? $toa : $tob;
- }
-
- bless \@o, 'CClass';
-}
-
-sub plus {
- my ($self, $other) = @_;
- _binop(sub { $_[0] | $_[1] }, $self, $other);
-}
-
-sub minus {
- my ($self, $other) = @_;
- _binop(sub { $_[0] & ~$_[1] }, $self, $other);
-}
-
-sub negate {
- my ($self) = @_;
- _binop(sub { 0x3FFF_FFFF & ~$_[0] }, $self, []);
-}
-
-our $Word = CClass->catm(qw< Lu Lt Ll Lm Lo Nd Nl No >)->plus('_');
-our $Digit = CClass->catm(qw< Nd Nl No >);
-our $Space = CClass->enum(' ', "\t", "\r", "\cK", "\n", "\x{3000}"); # TODO
-our $HSpace = CClass->enum("\t", " ", "\x{3000}");
-our $VSpace = CClass->enum("\r", "\cK", "\n");
-
-sub internal {
- my ($name) = @_;
- ($name eq 'alpha') && return CClass->catm(qw< Lu Lt Ll Lm Lo >)->plus('_');
- die "unknown internal cclass $name";
-}
-
-1;
View
0 v6/CClass.pm6 → src/CClass.pm6
File renamed without changes.
View
138 src/CgOp.pm
@@ -1,138 +0,0 @@
-use 5.010;
-use strict;
-use warnings;
-
-{
- package CgOpNode;
-}
-
-package CgOp;
-use Scalar::Util 'blessed';
-
-sub _cgop {
- if (grep { !defined } @_) {
- Carp::confess "Illegal undef in cgop $_[0]";
- }
- bless [@_], 'CgOpNode'
-}
-
-BEGIN {
- no warnings 'qw';
- my @names = qw<
- getfield, getindex, rawcall, rawnew, rawnewarr, rawnewzarr,
- rawscall, rawsget, rawsset, setfield, setindex,
-
- ann, arith, assign, bget, bif_at_key, bif_at_pos, bif_bool,
- bif_chars, bif_defined, bif_delete_key, bif_divide,
- bif_exists_key, bif_hash_keys, bif_hash_kv, bif_hash_pairs,
- bif_hash_values, bif_minus, bif_mul, bif_negate, bif_not,
- bif_num, bif_numeq, bif_numge, bif_numgt, bif_numle,
- bif_numlt, bif_numne, bif_plus, bif_postinc, bif_str,
- bif_streq, bif_strge, bif_strgt, bif_strle, bif_strlt,
- bif_strne, bif_substr3, bool, box, bset, callframe,
- call_uncloned_sub, cast, cgoto, char, class_ref, compare,
- const, context_get, control, corelex, cotake,
- cursor_backing, cursor_butpos, cursor_dows, cursor_fresh,
- cursor_from, cursor_item, cursor_O, cursor_pos,
- cursor_start, cursor_synthcap, cursor_synthetic,
- cursor_unpackcaps, default_new, die, do_require, double,
- ehspan, exit, fcclist_new, fetch, fladlist_new,
- foreign_class, frame_caller, frame_file, frame_hint,
- frame_line, from_jsync, fvarlist_item, fvarlist_length,
- fvarlist_new, getargv, get_first, getslot, goto, how,
- instrole, int, iter_copy_elems, iter_flatten, iter_hasarg,
- iter_hasflat, iter_to_list, label, labelid, letn, letvar,
- llhow_name, ncgoto, newblankrwscalar, newboundvar,
- newrwlistvar, newrwscalar, newscalar, newvarrayvar,
- newvhashvar, newvnewarrayvar, newvnewhashvar, newvsubvar,
- note, null, num_to_string, obj_asbool, obj_asdef, obj_asnum,
- obj_asstr, obj_at_key, obj_at_pos, obj_delete_key, obj_does,
- obj_exists_key, obj_getbool, obj_getdef, obj_getnum,
- obj_getstr, obj_isa, obj_is_defined, obj_llhow,
- obj_newblank, obj_typename, obj_vasbool, obj_vasdef,
- obj_vasnum, obj_vasstr, obj_vat_key, obj_vat_pos,
- obj_vdelete_key, obj_vexists_key, obj_what, popcut, print,
- prog, promote_to_list, pushcut, return, role_apply,
- rxbacktrack, rxbprim, rxcall, rxclosequant, rxcommitgroup,
- rxend, rxfinalend, rxframe, rxgetpos, rxgetquant,
- rxincquant, rxinit, rxopenquant, rxpushb, rxpushcapture,
- rxsetcapsfrom, rxsetclass, rxsetpos, rxsetquant,
- rxstripcaps, say, scopedlex, setbox, setslot, set_status,
- sig_slurp_capture, sink, slurp, span, specificlex, spew,
- stab_privatemethod, stab_what, startgather, status_get, str,
- strbuf_append, strbuf_new, strbuf_seal, str_chr, strcmp,
- str_length, str_substring, str_tolower, str_toupper, take,
- ternary, to_jsync, treader_getc, treader_getline,
- treader_slurp, treader_stdin, unbox, varhash_clear,
- varhash_contains_key, varhash_delete_key, varhash_dup,
- varhash_getindex, varhash_new, varhash_setindex, var_islist,
- vvarlist_append, vvarlist_clone, vvarlist_count,
- vvarlist_from_fvarlist, vvarlist_item, vvarlist_new_empty,
- vvarlist_new_singleton, vvarlist_pop, vvarlist_push,
- vvarlist_shift, vvarlist_sort, vvarlist_to_fvarlist,
- vvarlist_unshift, vvarlist_unshiftn, whileloop,
- get_lexer, run_protoregex, label_table, mrl_count, mrl_index,
- treader_open, bif_make, cursor_ast, to_json, from_json,
- >;
-
- my $code;
- for my $n (@names) {
- chop $n;
- $code .= "sub $n { _cgop(\"$n\", \@_) }\n";
- }
- eval $code;
-}
-
-sub _str { blessed($_[0]) ? $_[0] : str($_[0]) }
-sub _int { blessed($_[0]) ? $_[0] : CgOp::int($_[0]) }
-
-sub newblanklist { methodcall(corelex('Array'), 'new') }
-sub newblankhash { methodcall(corelex('Hash'), 'new') }
-sub string_var { box('Str', str($_[0])); }
-sub noop { prog() }
-sub rnull { prog($_[0], corelex('Nil')); }
-sub getattr { fetch(varattr($_[0], $_[1])); }
-sub varattr { getslot($_[0], 'var', $_[1]); }
-
-my $nextlet = 0;
-sub let {
- my ($head, $bodyf) = @_;
- my $v = ($nextlet++);
- letn($v, $head, $bodyf->(letvar($v)));
-}
-
-sub cc_expr { _cgop('newcc', @{ $_[0] }) }
-sub construct_lad { _cgop('ladconstruct', @_) }
-
-sub _process_arglist {
- my $ar = shift;
- my $sig = '';
- my $j = 0;
- for (my $i = 0; $i < @$ar; ) {
- my $o = $ar->[$i];
- if (blessed($o)) {
- $sig .= "\0";
- } else {
- $sig .= chr(length($o)) . $o;
- $i++;
- }
- $ar->[$j++] = $ar->[$i++];
- }
- $#$ar = $j - 1;
- $sig;
-}
-
-sub subcall {
- my ($sub, @args) = @_;
- my $sig = _process_arglist(\@args);
- _cgop('subcall', $sig, $sub, @args);
-}
-
-sub methodcall {
- my ($obj, $name, @args) = @_;
- my $sig = _process_arglist(\@args);
- let($obj, sub {
- _cgop('methodcall', $name, $sig, fetch($_[0]), $_[0], @args)});
-}
-
-1;
View
0 v6/CgOp.pm6 → src/CgOp.pm6
File renamed without changes.
View
288 src/CompilerDriver.pm
@@ -1,288 +0,0 @@
-package CompilerDriver;
-use strict;
-use warnings;
-use 5.010;
-
-use Sub::Exporter -setup => {
- exports => [ qw(compile) ]
-};
-
-use Time::HiRes 'time';
-use File::Basename;
-use autodie ':all';
-
-use Body ();
-use Unit ();
-use Op ();
-use Optimizer::Beta ();
-use Optimizer::Simplifier ();
-use Metamodel ();
-use NAMBackend ();
-
-use Niecza::Grammar ();
-use Niecza::Actions ();
-
-my ($srcdir, $rootdir, $builddir, $libdir);
-{
- $srcdir = dirname($INC{'CompilerDriver.pm'});
- $rootdir = dirname($srcdir);
- $builddir = File::Spec->catdir($rootdir, "obj");
- $libdir = File::Spec->catdir($rootdir, "lib");
-}
-File::Path::make_path($builddir);
-
-sub build_file { File::Spec->catfile($builddir, $_[0]) }
-
-sub slurp {
- my ($name) = @_;
- open my $text, "<", $name;
- local $/;
- my $bits = <$text>;
- close $text;
- $bits;
-}
-
-sub metadata_for {
- my ($unit) = @_;
- my $file = "$unit.nam";
- $file =~ s/::/./g;
-
- $Metamodel::units{$unit} //= NAMBackend::load(slurp(build_file($file)));
-}
-
-sub syml_for {
- my ($module, $file) = @_;
- local %Metamodel::units;
- my $meta = $Metamodel::units{$module} //=
- NAMBackend::load(slurp($file));
-
- if ($meta->name ne $module) {
- Carp::cluck("syml_for incoherence");
- }
-
- for my $dmod (keys %{ $meta->tdeps }) {
- next if $dmod eq $module;
- $Metamodel::units{$dmod} = CompilerDriver::metadata_for($dmod);
- }
-
- return $meta->create_syml;
-}
-
-sub get_perl6lib {
- File::Spec->curdir, $libdir
-}
-
-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 defined($issetting) && ($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;
- no warnings 'redefine';
-
- sub sys_save_syml {
- my ($self, $all) = @_;
- }
-
- sub sys_do_compile_module {
- my ($self, $mod, $syml, $file) = @_;
- CompilerDriver::compile(name => $mod, stagetime => $::stagetime);
- }
-
- sub sys_load_modinfo {
- my $self = shift;
- my $module = shift;
-
- # these are handled in the compiler itself
- return { } if $module eq 'MONKEY_TYPING' || $module eq 'lib' ||
- $module eq 'fatal';
-
- my $csmod = $module;
- $csmod =~ s/::/./g;
- my ($namfile) = CompilerDriver::build_file("$csmod.nam");
- my ($modfile) = CompilerDriver::find_module($module, 0) or do {
- $self->sorry("Cannot locate module $module");
- return undef;
- };
-
- REUSE: {
- last REUSE unless -f $namfile;
- my $meta = CompilerDriver::metadata_for($module);
-
- for my $dmod ($module, keys %{ $meta->tdeps }) {
- my $u = CompilerDriver::metadata_for($dmod);
- my ($dpath, $dtime) = @{ $meta->tdeps->{$dmod} //
- [ $meta->filename, $meta->modtime ] };
-
- my ($npath) = CompilerDriver::find_module($dmod, undef) or do {
- $self->sorry("Dependancy $dmod of $module cannot be located");
- return undef;
- };
-
- $npath = Cwd::realpath($npath);
- if ($npath ne $dpath) {
- print STDERR "Recompiling $module because dependancy $dmod now points to $npath, was $dpath\n";
- last REUSE;
- }
-
- my $ntime = (stat $npath)[9];
- if ($ntime ne $dtime) {
- print STDERR "Recompiling $module because dependancy $dmod is newer ($dtime -> $ntime)\n";
- last REUSE;
- }
- }
-
- return CompilerDriver::syml_for($module, $namfile);
- }
-
- $self->sys_compile_module($module, $namfile, $modfile);
- CompilerDriver::syml_for($module, $namfile);
- }
-
- sub load_lex {
- my $self = shift;
- my $setting = shift;
- my $settingx = $setting;
- $settingx =~ s/::/./g;
-
- if ($setting eq 'NULL') {
- my $id = "MY:file<NULL.pad>:line(1):pos(0)";
- my $core = Stash->new('!id' => [$id], '!file' => 'NULL.pad',
- '!line' => 1);
- return Stash->new('CORE' => $core, 'MY:file<NULL.pad>' => $core,
- 'SETTING' => $core, $id => $core);
- }
-
- my $astf = File::Spec->catfile($builddir, "$settingx.nam");
- if (-e $astf) {
- return CompilerDriver::syml_for($setting, $astf);
- }
-
- $self->sorry("Unable to load setting $setting.");
- return $self->load_lex("NULL");
- }
-}
-
-sub compile {
- my %args = @_;
-
- 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 // 0);
- if (!defined($path)) {
- Carp::croak("Module $name not found");
- }
- }
-
- local %Metamodel::units;
- local $::stagetime = $args{stagetime};
- local $::SETTING_UNIT;
- local $::YOU_WERE_HERE;
- local $::UNITNAME = $name // 'MAIN';
- $::UNITNAME =~ s/::/./g;
- local $::SAFEMODE = $safe;
- $STD::ALL = {};
- my ($filename, $modtime);
-
- if ($lang ne 'NULL') {
- $::SETTING_UNIT = $lang;
- }
-
- if (defined($name)) {
- $filename = Cwd::realpath($path);
- $modtime = ((stat $filename)[9]);
- }
-
- my ($m, $a) = defined($path) ? (parsefile => $path) : (parse => $code);
-
- my $ast;
- my $basename = $::UNITNAME;
- my $namfile = File::Spec->catfile($builddir, "$basename.nam");
- my $outfile = File::Spec->catfile($builddir,
- $basename . (defined($name) ? ".dll" : ".exe"));
-
- my @phases = (
- [ 'parse', sub {
- $ast = Niecza::Grammar->$m($a, setting => $lang,
- actions => 'Niecza::Actions')->{_ast}; } ],
- [ 'begin', sub {
- $ast = $ast->begin;
- if (defined $name) {
- $ast->filename($filename);
- $ast->modtime($modtime);
- }
- } ],
- [ 'beta', sub { Optimizer::Beta::run($ast) } ],
- [ 'simpl', sub { Optimizer::Simplifier::run($ast) } ],
- [ 'nam', sub { $ast = [$ast, NAMBackend::run($ast)] } ],
- [ 'writenam', sub {
- open my $fh, ">", $namfile;
- print $fh $ast->[1];
- close $fh;
- $ast = undef;
- } ],
- [ 'codegen', sub {
- my @args = ("mono",
- File::Spec->catfile($builddir, "CLRBackend.exe"), $builddir,
- "$basename.nam", (defined($name) ? ("$basename.dll", "0") :
- ("$basename.exe", "1")));
- print STDERR "@args\n" if $args{stagetime};
- system @args;
- $ast = undef;
- } ],
- [ 'aot', sub {
- system "mono", "--aot", $outfile;
- } ]);
-
- for my $p (@phases) {
- next if $p->[0] eq 'aot' && !$args{aot};
- my $t1 = time if $args{stagetime};
- $p->[1]->();
- my $t2 = time if $args{stagetime};
- printf "%-20s: %gs\n", "$basename " . $p->[0],
- $t2 - $t1 if $args{stagetime};
- if ($args{stopafter} && $args{stopafter} eq $p->[0]) {
- if ($ast && $args{stopafter} ne 'writenam') {
- print STDERR YAML::XS::Dump($ast);
- }
- return;
- }
- }
-}
-
-1;
View
1,320 src/Metamodel.pm
@@ -1,1320 +0,0 @@
-use 5.010;
-use strict;
-use warnings;
-use utf8;
-
-package Metamodel;
-use Unit;
-use Body;
-use Op;
-use RxOp;
-use Sig;
-use YAML::XS;
-use Scalar::Util 'blessed';
-
-### NIECZA COMPILER METAMODEL
-# The metamodel exists to create a timeline inside the compiler. Previously,
-# the compiler operated as a pure tree transformer with no conception of how
-# PRE-INIT code would play out, thus precluding a lot of important
-# optimizations (based on precomputing immutable objects and optimizing
-# references to them, mostly).
-#
-# The metamodel has two main life stages. First, it is built; an incremental
-# process logically called BEGIN. Then, it is processed to perform closed-
-# world optimizations and generate code; this is (UNIT)CHECK.
-#
-# Kinds of objects which exist in the metamodel
-# - Static subs
-# - Packages (incl. classes, modules, grammars)
-# - Stashes (Foo::)
-#
-# This graph is a lot more random than the old trees were...
-
-# these should only be used during the Op walk
-our @opensubs;
-our $unit;
-our %units;
-
-# A stash is an object like Foo::. Foo and Foo:: are closely related, but
-# generally must be accessed separately due to constants (which have Foo but
-# not Foo::) and stub packages (vice versa).
-#
-# 'my' stashes are really 'our' stashes with gensym mergable names. Because
-# stashes have no identity beyond their contents and set of names, they don't
-# mind being copied around a lot.
-#
-# Stashes are not referencable objects in precompilation mode. You need to
-# keep the paths around, instead.
-#
-# This object holds the stash universe for a unit.
-{
- package Metamodel::Namespace;
- use Moose;
-
- # root points to a graph of hashes each representing one package.
- # Each such hash has keys for each member; the values are arrayrefs:
- # ["graft", [@path]]: A graft
- # ["var", $meta, $sub]: A common variable and/or subpackage; either
- # field may be undef.
- #
- # Paths do not start from GLOBAL; they start from an unnamed package
- # which contains GLOBAL, and also lexical namespaces (MAIN 15 etc).
- has root => (is => 'rw', default => sub { +{} });
-
- # Records *local* operations, so they may be stored and used to
- # set up the runtime stashes. Read-only log access is part of the
- # public API.
- has log => (is => 'ro', default => sub { [] });
-
- sub stash_cname {
- my ($self, @path) = @_;
- (_lookup_common($self, [], @path))[1,2];
- }
-
- sub stash_canon {
- my ($self, @path) = @_;
- my ($npath, $nhead) = $self->stash_cname(@path);
- @$npath, $nhead;
- }
-
- sub visit_stashes {
- my ($self, $cb) = @_;
- _visitor($self->root, $cb);
- }
-
- sub _visitor {
- my ($node, $cb, @path) = @_;
- $cb->(\@path);
- for my $k (sort keys %$node) {
- if ($node->{$k}[0] eq 'var' && $node->{$k}[2]) {
- _visitor($node->{$k}[2], $cb, @path, $k);
- }
- }
- }
-
- # Add a new unit set to the from-set and checks mergability
- sub add_from {
- my ($self, $from) = @_;
- $self->root(_merge($self->root, $units{$from}->ns->root));
- }
-
- sub _merge {
- my ($rinto, $rfrom, @path) = @_;
- $rinto = { %$rinto };
- for my $k (sort keys %$rfrom) {
- if (!$rinto->{$k}) {
- $rinto->{$k} = $rfrom->{$k};
- next;
- }
- my $i1 = $rinto->{$k};
- my $i2 = $rfrom->{$k};
- if ($i1->[0] ne $i2->[0]) {
- die "Merge type conflict " . join(" ", $i1->[0], $i2->[0], @path, $k);
- }
- if ($i1->[0] eq 'graft') {
- die "Grafts cannot be merged " . join(" ", @path, $k)
- unless join("\0", @{ $i1->[1] }) eq join("\0", @{ $i2->[1] });
- }
- if ($i1->[0] eq 'var') {
- my $nn1 = $i1->[1] && $i1->[1][0];
- my $nn2 = $i2->[1] && $i2->[1][0];
- die "Non-stub packages cannot be merged " . join(" ", @path, $k, ";", @{$i1->[1]}, ";", @{$i2->[1]})
- if $nn1 && $nn2 && ($i1->[1][0] ne $i2->[1][0] ||
- $i1->[1][1] != $i2->[1][1]);
- my $obj = $nn1 ? $i1->[1] : $nn2 ? $i2->[1] :
- ($i1->[1] // $i2->[1]);
- my $child =
- ($i1->[2] && $i2->[2]) ? _merge($i1->[2], $i2->[2], @path, $k) :
- ($i1->[2] // $i2->[2]);
- $rinto->{$k} = ['var', $obj, $child];
- }
- }
- return $rinto;
- }
-
- sub _lookup_common {
- my ($self, $used, @path) = @_;
- my $cursor = $self->root;
- while (@path > 1) {
- my $k = shift @path;
- if ($cursor->{$k} && $cursor->{$k}[0] eq 'graft') {
- ($cursor, $used) = _lookup_common($self, [], @{$cursor->{$k}[1]}, '');
- next;
- }
-
- $cursor->{$k} //= ['var',undef,undef];
- if (!$cursor->{$k}[2]) {
- push @{ $self->log }, ['pkg',[@$used, $k]];
- $cursor->{$k}[2] = {};
- }
- $cursor = $cursor->{$k}[2];
- push @$used, $k;
- }
- ($cursor, $used, @path);
- }
-
- # Create or reuse a (stub) package for a given path
- sub create_stash {
- my ($self, @path) = @_;
- _lookup_common($self, [], @path, '');
- }
-
- # Create or reuse a variable for a given path
- sub create_var {
- my ($self, @path) = @_;
- my ($c,$u,$n) = _lookup_common($self, [], @path);
- my $i = $c->{$n} //= ['var',undef,undef];
- if ($i->[0] ne 'var') {
- die "Collision with non-variable on @path";
- }
- if (!$i->[1]) {
- push @{ $self->log }, [ 'var', [ @$u,$n ] ];
- $i->[1] = ['',0];
- }
- }
-
- # Lookup by name; returns undef if not found
- sub get_item {
- my ($self, @path) = @_;
- my ($c,$u,$n) = _lookup_common($self, [], @path);
- my $i = $c->{$n} or return undef;
- if ($i->[0] eq 'graft') {
- return $self->get_item(@{ $i->[1] });
- } elsif ($i->[0] eq 'var') {
- return $i->[1];
- }
- }
-
- # Bind an unmergable thing (non-stub package) into a stash.
- sub bind_item {
- my ($self, $path, $item) = @_;
- my ($c,$u,$n) = _lookup_common($self, [], @$path);
- my $i = $c->{$n} //= ['var',undef,undef];
- if ($i->[0] ne 'var' || ($i->[1] && $i->[1][0])) {
- die "Collision installing pkg @$path";
- }
- $i->[1] = $item;
- }
-
- # Bind a graft into a stash
- sub bind_graft {
- my ($self, $path1, $path2) = @_;
- my ($c,$u,$n) = _lookup_common($self, [], @$path1);
- if ($c->{$n}) {
- die "Collision installing graft @$path1 -> @$path2";
- }
- push @{ $self->log }, [ 'graft', [ @$u, $n ], $path2 ];
- $c->{$n} = ['graft', $path2];
- }
-
- # List objects in a stash for use by the importer; returns tuples
- # of [name, var] etc
- sub list_stash {
- my ($self, @path) = @_;
- my ($c) = _lookup_common($self, [], @path, '');
- my @out;
- map { [ $_, @{ $c->{$_} } ] } sort keys %$c;
- }
-
- no Moose;
- __PACKAGE__->meta->make_immutable;
-}
-
-{
- package Metamodel::RefTarget;
- use Moose;
-
- has xref => (isa => 'ArrayRef', is => 'rw');
- has name => (isa => 'Str', is => 'ro', default => 'ANON');
-
- sub BUILD {
- $_[0]->xref([ $unit->name, scalar(@{ $unit->xref }), $_[0]->name ]);
- push @{ $unit->xref }, $_[0];
- }
-
- no Moose;
- __PACKAGE__->meta->make_immutable;
-}
-
-{
- package Metamodel::Package;
- use Moose;
- extends 'Metamodel::RefTarget';
-
- has exports => (is => 'rw', isa => 'ArrayRef[ArrayRef[Str]]');
-
- sub add_attribute {
- my ($self, $name, $public, $ivar, $ibody) = @_;
- die "attribute $name defined in a lowly package";
- }
-
- sub add_method {
- my ($self, $kind, $name, $var, $body) = @_;
- die "method $name defined in a lowly package";
- }
-
- sub add_super {
- my ($self, $super) = @_;
- die "superclass " . $unit->deref($super)->name .
- " defined in a lowly package";
- }
-
- sub close { }
-
- no Moose;
- __PACKAGE__->meta->make_immutable;
-}
-
-{
- package Metamodel::Module;
- use Moose;
- extends 'Metamodel::Package';
-
- no Moose;
- __PACKAGE__->meta->make_immutable;
-}
-
-{
- package Metamodel::Class;
- use Moose;
- extends 'Metamodel::Module';
-
- has attributes => (isa => 'ArrayRef[Metamodel::Attribute]', is => 'ro',
- default => sub { [] });
- has methods => (isa => 'ArrayRef[Metamodel::Method]', is => 'ro',
- default => sub { [] });
- has superclasses => (isa => 'ArrayRef', is => 'ro',
- default => sub { [] });
- has linearized_mro => (isa => 'ArrayRef[ArrayRef]', is => 'rw');
- has _closing => (isa => 'Bool', is => 'rw');
-
- sub add_attribute {
- my ($self, $name, $public, $ivar, $ibody) = @_;
- push @{ $self->attributes }, Metamodel::Attribute->new(name => $name,
- public => $public, ivar => $ivar, ibody => $ibody);
- }
-
- sub add_method {
- my ($self, $kind, $name, $var, $body) = @_;
- push @{ $self->methods }, Metamodel::Method->new(name => $name,
- body => $body, kind => $kind);
- }
-
- sub add_super {
- my ($self, $targ) = @_;
- Carp::confess "bad attempt to add null super" unless $targ;
- push @{ $self->superclasses }, $targ;
- }
-
- sub close {
- my ($self) = @_;
-
- return if $self->linearized_mro;
- if ($self->_closing) {
- die "Class hierarchy circularty detected at ", $self->name, "\n";
- }
- $self->_closing(1);
-
- if (($self->name ne 'Mu' || !$unit->is_true_setting)
- && !@{ $self->superclasses }) {
- $self->add_super($unit->get_item(
- @{ $opensubs[-1]->true_setting->find_pkg($self->_defsuper) }));
- }
-
- my @merge;
- push @merge, [ $self->xref, @{ $self->superclasses } ];
- for (@{ $self->superclasses }) {
- my $d = $unit->deref($_);
- $d->close unless $d->linearized_mro;
- push @merge, [ @{ $d->linearized_mro } ];
- }
- my @mro;
- my %used;
-
- MRO: for(;;) {
- CANDIDATE: for (my $i = 0; $i < @merge; $i++) {
- my $item = $merge[$i][0];
- for (my $j = 0; $j < @merge; $j++) {
- for (my $k = 1; $k < @{ $merge[$j] }; $k++) {
- next CANDIDATE if $unit->deref($merge[$j][$k])
- == $unit->deref($item);
- }
- }
- shift @{ $merge[$i] };
- splice @merge, $i, 1 if !@{ $merge[$i] };
- push @mro, $item unless $used{$unit->deref($item)}++;
- next MRO;
- }
- last MRO if (!@merge);
- die "C3-MRO wedged! " . join(" | ", map { (join " <- ",
- map { $unit->deref($_)->name } @$_) } @merge);
- }
-
- $self->linearized_mro(\@mro);
- }
-
- sub _defsuper { 'Any' }
-
- no Moose;
- __PACKAGE__->meta->make_immutable;
-}
-
-# roles come in two types; Role objects are used for simple roles, while roles
-# with parameters get ParametricRole. Instantiations of parametric roles
-# would get ConcreteRole, but that won't be implemented in Niecza A since it
-# requires evaluating role parameters, unless we restrict it to typenames or
-# something.
-{
- package Metamodel::Role;
- use Moose;
- extends 'Metamodel::Module';
-
- has attributes => (isa => 'ArrayRef[Metamodel::Attribute]', is => 'ro',
- default => sub { [] });
- has methods => (isa => 'ArrayRef[Metamodel::Method]', is => 'ro',
- default => sub { [] });
- has superclasses => (isa => 'ArrayRef', is => 'ro',
- default => sub { [] });
-
- sub add_attribute {
- my ($self, $name, $public, $ivar, $ibody) = @_;
- push @{ $self->attributes }, Metamodel::Attribute->new(name => $name,
- public => $public, ivar => $ivar, ibody => $ibody);
- }
-
- sub add_method {
- my ($self, $kind, $name, $var, $body) = @_;
- if (blessed $name) {
- die "Computed names are legal only in parametric roles";
- }
- push @{ $self->methods }, Metamodel::Method->new(name => $name,
- body => $body, kind => $kind);
- }
-
- sub add_super {
- my ($self, $targ) = @_;
- Carp::confess "bad attempt to add null super" unless $targ;
- push @{ $self->superclasses }, $targ;
- }
-
- no Moose;
- __PACKAGE__->meta->make_immutable;
-}
-
-{
- package Metamodel::ParametricRole;
- use Moose;
- extends 'Metamodel::Module';
-
- has attributes => (isa => 'ArrayRef[Metamodel::Attribute]', is => 'ro',
- default => sub { [] });
- has methods => (isa => 'ArrayRef[Metamodel::Method]', is => 'ro',
- default => sub { [] });
- has superclasses => (isa => 'ArrayRef', is => 'ro',
- default => sub { [] });
-
- sub add_attribute {
- my ($self, $name, $public, $ivar, $ibody) = @_;
- push @{ $self->attributes }, Metamodel::Attribute->new(name => $name,
- public => $public, ivar => $ivar, ibody => $ibody);
- }
-
- sub add_method {
- my ($self, $kind, $name, $var, $body) = @_;
- push @{ $self->methods }, Metamodel::Method->new(name => $name,
- var => $var, kind => $kind);
- }
-
- sub add_super {
- my ($self, $targ) = @_;
- Carp::confess "bad attempt to add null super" unless $targ;
- push @{ $self->superclasses }, $targ;
- }
-
-
- no Moose;
- __PACKAGE__->meta->make_immutable;
-}
-
-{
- package Metamodel::Grammar;
- use Moose;
- extends 'Metamodel::Class';
-
- sub _defsuper { 'Grammar' }
-
- no Moose;
- __PACKAGE__->meta->make_immutable;
-}
-
-{
- package Metamodel::Method;
- use Moose;
-
- # normally a Str, but may be Op for param roles
- has name => (is => 'ro', required => 1);
- # normal, private, meta, sub
- has kind => (isa => 'Str', is => 'ro', required => 1);
- has var => (isa => 'Str', is => 'ro');
- has body => (isa => 'ArrayRef', is => 'ro');
-
- no Moose;
- __PACKAGE__->meta->make_immutable;
-}
-
-{
- package Metamodel::Attribute;
- use Moose;
-
- has name => (isa => 'Str', is => 'ro', required => 1);
- has public => (isa => 'Bool', is => 'ro');
- has ivar => (isa => 'Maybe[Str]', is => 'ro');
- has ibody => (isa => 'Maybe[ArrayRef]', is => 'ro');
-
- no Moose;
- __PACKAGE__->meta->make_immutable;
-}
-
-
-# This is a static lexical; they exist in finite number per unit. They may
-# occupy specific slots in pads, or globals, or something else entirely.
-{
- package Metamodel::Lexical;
- use Moose;
-
- no Moose;
- __PACKAGE__->meta->make_immutable;
-}
-
-# my $foo, @foo, %foo, &foo
-{
- package Metamodel::Lexical::Simple;
- use Moose;
- extends 'Metamodel::Lexical';
-
- has list => (isa => 'Bool', is => 'ro', default => 0);
- has hash => (isa => 'Bool', is => 'ro', default => 0);
- has noinit => (isa => 'Bool', is => 'ro', default => 0);
-
- no Moose;
- __PACKAGE__->meta->make_immutable;
-}
-
-# These are used for $?foo et al, and should be inaccessible until assigned,
-# although the current code won't enforce that well.
-{
- package Metamodel::Lexical::Hint;
- use Moose;
- extends 'Metamodel::Lexical';
-
- no Moose;
- __PACKAGE__->meta->make_immutable;
-}
-
-# our...
-{
- package Metamodel::Lexical::Common;
- use Moose;
- extends 'Metamodel::Lexical';
-
- has path => (isa => 'ArrayRef[Str]', is => 'ro', required => 1);
- has name => (isa => 'Str', is => 'ro', required => 1);
-
- no Moose;
- __PACKAGE__->meta->make_immutable;
-}
-
-# mostly for state
-{
- package Metamodel::Lexical::Alias;
- use Moose;
- extends 'Metamodel::Lexical';
-
- has to => (isa => 'Str', is => 'ro', required => 1);
- sub BUILDARGS { +{ to => $_[1] } }
-
- no Moose;
- __PACKAGE__->meta->make_immutable;
-}
-
-# sub foo { ... }
-{
- package Metamodel::Lexical::SubDef;
- use Moose;
- extends 'Metamodel::Lexical';
-
- has body => (isa => 'Metamodel::StaticSub', is => 'ro');
-
- no Moose;
- __PACKAGE__->meta->make_immutable;
-}
-
-# my class Foo { } or our class Foo { }; either case, the true stash lives in
-# stashland
-{
- package Metamodel::Lexical::Stash;
- use Moose;
- extends 'Metamodel::Lexical';
-
- has path => (isa => 'ArrayRef[Str]', is => 'ro');
-
- no Moose;
- __PACKAGE__->meta->make_immutable;
-}
-
-# The life cycle of a static sub has three phases.
-# 1. Open - the end of the sub hasn't been seen, so the full code is absent.
-# 2. Closing - all attributes are available but no references exist. The
-# perfect time for most optimizations, especially ones that look like
-# escape analyses.
-# 3. Closed - references exist, possibly even from BEGIN-run code. The sub
-# must be treated as semantically immutable. The code can probably still
-# be changed to reflect new information, though.
-
-# figure out how post-declared lexicals should interact with codegen
-# std accepts: sub foo() { bar }; BEGIN { foo }; sub bar() { }
-# DONE: TimToady says bar can be compiled to a runtime search
-{
- package Metamodel::StaticSub;
- use Moose;
- extends 'Metamodel::RefTarget';
-
- has unit => (isa => 'Metamodel::Unit', is => 'ro', weak_ref => 1);
- has outer => (is => 'bare');
- has run_once => (isa => 'Bool', is => 'ro', default => 0);
- has spad_exists => (isa => 'Bool', is => 'rw', default => 0);
-
- has lexicals => (isa => 'HashRef[Metamodel::Lexical]', is => 'ro',
- default => sub { +{} });
- has code => (isa => 'Op', is => 'rw');
- has signature=> (isa => 'Maybe[Sig]', is => 'rw');
- has zyg => (isa => 'ArrayRef[Metamodel::StaticSub]', is => 'ro',
- default => sub { [] });
-
- # inject a take EMPTY
- has gather_hack => (isa => 'Bool', is => 'ro', default => 0);
- # inject a role constructor
- has parametric_role_hack => (isa => 'Maybe[ArrayRef]', is => 'rw');
- # some tuples for method definitions; munged into a phaser
- has augment_hack => (isa => 'Maybe[ArrayRef]', is => 'rw');
- # emit code to assign to a hint; [ $subref, $name ]
- has hint_hack => (isa => 'Maybe[ArrayRef]', is => 'rw');
- has is_phaser => (isa => 'Maybe[Int]', is => 'rw', default => undef);
- has strong_used => (isa => 'Bool', is => 'rw', default => 0);
- has body_of => (isa => 'Maybe[ArrayRef]', is => 'ro');
- has in_class => (isa => 'Maybe[ArrayRef]', is => 'ro');
- has cur_pkg => (isa => 'Maybe[ArrayRef[Str]]', is => 'ro');
- has returnable => (isa => 'Bool', is => 'ro', default => 0);
- has augmenting => (isa => 'Bool', is => 'ro', default => 0);
- has class => (isa => 'Str', is => 'ro', default => 'Sub');
- has ltm => (is => 'rw');
- has exports => (is => 'rw');
-
- sub outer {
- my $v = $_[0]{outer};
- return $v if !$v or blessed($v);
- $_[0]{unit}->deref($v);
- }
-
- sub true_setting {
- my $cursor = $_[0];
- while ($cursor && !$cursor->unit->is_true_setting) {
- $cursor = $cursor->outer;
- }
- $cursor;
- }
-
- sub add_child { push @{ $_[0]->zyg }, $_[1] }
- sub children { @{ $_[0]->zyg } }
-
- sub create_static_pad {
- my ($self) = @_;
-
- return if $self->spad_exists;
- $self->spad_exists(1);
- $self->outer->create_static_pad if $self->outer;
- }
-
- sub find_lex_pkg { my ($self, $name) = @_;
- my $toplex = $self->find_lex($name) // return undef;
- if (!$toplex->isa('Metamodel::Lexical::Stash')) {
- die "$name is declared as a non-package";
- }
- $toplex->path;
- }
-
- sub find_pkg { my ($self, $names) = @_;
- my @names = ref($names) ? @$names : ('MY', $names);
- $_ =~ s/::$// for (@names); #XXX
- my @tp;
- if ($names[0] eq 'OUR') {
- @tp = @{ $self->cur_pkg };
- shift @names;
- } elsif ($names[0] eq 'PROCESS' or $names[0] eq 'GLOBAL') {
- @tp = shift(@names);
- } elsif ($names[0] eq 'MY') {
- @tp = @{ $self->find_lex_pkg($names[1]) };
- splice @names, 0, 2;
- } elsif (my $p = $self->find_lex_pkg($names->[0])) {
- @tp = @$p;
- shift @names;
- } else {
- @tp = 'GLOBAL';
- }
-
- [ @tp, @names ];
- }
-
- sub find_lex { my ($self, $name) = @_;
- my $l = $self->lexicals->{$name};
- if ($l) {
- return $l->isa('Metamodel::Lexical::Alias') ?
- $self->find_lex($l->to) : $l;
- }
- return ($self->outer ? $self->outer->find_lex($name) : undef);
- }
-
- sub delete_lex { my ($self, $name) = @_;
- my $l = $self->lexicals->{$name};
- if ($l) {
- if ($l->isa('Metamodel::Lexical::Alias')) { $self->delete_lex($l->to) }
- else { delete $self->lexicals->{$name} }
- } else {
- $self->outer && $self->outer->delete_lex($name);
- }
- }
-
- sub add_my_name { my ($self, $slot, @ops) = @_;
- $self->lexicals->{$slot} = Metamodel::Lexical::Simple->new(@ops);
- }
-
- sub add_hint { my ($self, $slot) = @_;
- $self->lexicals->{$slot} = Metamodel::Lexical::Hint->new;
- }
-
- sub add_common_name { my ($self, $slot, $path, $name) = @_;
- $unit->create_stash(@$path);
- $unit->create_var(@$path, $name);
- $self->lexicals->{$slot} = Metamodel::Lexical::Common->new(
- path => $path, name => $name);
- }
-
- sub add_state_name { my ($self, $slot, $back, @ops) = @_;
- # outermost sub isn't cloned so a fallback to my is safe
- my $up = $self->outer // $self;
- $up->lexicals->{$back} = Metamodel::Lexical::Simple->new(@ops);
- $self->lexicals->{$slot} = Metamodel::Lexical::Alias->new($back)
- if defined($slot);
- }
-
- sub add_my_stash { my ($self, $slot, $path) = @_;
- $self->lexicals->{$slot} = Metamodel::Lexical::Stash->new(
- path => $path);
- }
-
- sub add_my_sub { my ($self, $slot, $body) = @_;
- $self->add_child($body);
- $self->lexicals->{$slot} = Metamodel::Lexical::SubDef->new(
- body => $body);
- }
-
- sub add_pkg_exports { my ($self, $unit, $name, $path2, $tags) = @_;
- for my $tag (@$tags) {
- $unit->bind_graft([@{ $self->cur_pkg }, 'EXPORT', $tag, $name],
- $path2);
- }
- scalar @$tags;
- }
-
- # NOTE: This only marks the variables as used. The code generator
- # still has to spit out assignments for these!
- sub add_exports { my ($self, $unit, $name, $tags) = @_;
- for my $tag (@$tags) {
- $unit->create_var(@{ $self->cur_pkg }, 'EXPORT', $tag, $name);
- }
- scalar @$tags;
- }
-
- sub close { }
-
- no Moose;
- __PACKAGE__->meta->make_immutable;
-}
-
-{
- package Metamodel::Unit;
- use Moose;
-
- has mainline => (isa => 'Metamodel::StaticSub', is => 'rw');
- has name => (isa => 'Str', is => 'ro');
- has ns => (isa => 'Metamodel::Namespace', is => 'ro',
- handles => [qw/ bind_item bind_graft create_stash create_var
- list_stash get_item /]);
-
- has setting => (isa => 'Maybe[Str]', is => 'ro');
- # ref to parent of Op::YouAreHere
- has bottom_ref => (is => 'rw');
-
- has xref => (isa => 'ArrayRef', is => 'ro', default => sub { [] });
- has tdeps => (isa => 'HashRef[ArrayRef]', is => 'ro',
- default => sub { +{} });
-
- has filename => (isa => 'Maybe[Str]', is => 'rw');
- has modtime => (isa => 'Maybe[Num]', is => 'rw');
-
- has next_anon_stash => (isa => 'Int', is => 'rw', default => 0);
-
- sub is_true_setting { $_[0]->name eq 'SAFE' || $_[0]->name eq 'CORE' }
-
- sub get_unit {
- my ($self, $name) = @_;
- $units{$name} // Carp::confess "invalid unit ref $name";
- }
-
- sub anon_stash {
- my $i = $_[0]->next_anon_stash;
- $_[0]->next_anon_stash($i+1);
- $_[0]->name . ":" . $i;
- }
-
- sub deref {
- my ($self, $thing) = @_;
- Carp::confess "trying to dereference null" unless $thing;
- return $self->get_unit($thing->[0])->xref->[$thing->[1]] //
- Carp::confess "invalid ref @$thing";
- }
-
- sub visit_units_preorder {
- my ($self, $cb) = @_;
- my %seen;
- our $rec; local $rec = sub {
- return if $seen{$_};
- $seen{$_} = 1;
- for (sort keys %{ $self->get_unit($_)->tdeps }) {
- $rec->();
- }
- $cb->($_) for ($self->get_unit($_));
- };
- $rec->() for ($self->name);
- }
-
- sub visit_local_packages {
- my ($self, $cb) = @_;
- for (@{ $self->xref }) {
- $cb->($_) if defined($_) && $_->isa('Metamodel::Package');
- }
- }
-
- sub visit_local_subs_postorder {
- my ($self, $cb) = @_;
- our $rec; local $rec = sub {
- for ($_->children) { $rec->(); }
- $cb->($_);
- };
- for ($self->mainline) { $rec->(); }
- }
-
- sub visit_local_subs_preorder {
- my ($self, $cb) = @_;
- our $rec; local $rec = sub {
- $cb->($_);
- for ($_->children) { $rec->(); }
- };
- for ($self->mainline) { $rec->(); }
- }
-
- sub need_unit {
- my ($self, $u2name) = @_;
- my $u2 = $units{$u2name} //= CompilerDriver::metadata_for($u2name);
- $self->tdeps->{$u2name} = [ $u2->filename, $u2->modtime ];
- for (keys %{ $u2->tdeps }) {
- $units{$_} //= CompilerDriver::metadata_for($_);
- $self->tdeps->{$_} //= $u2->tdeps->{$_};
- }
- $self->ns->add_from($u2name);
- $u2;
- }
-
- # STD-based frontend wants a slightly different representation.
- sub _syml_myname {
- my ($xr) = @_;
- "MY:unit<" . $xr->[0] . ">:xid<" . $xr->[1] . ">";
- }
-
- sub create_syml {
- my ($self) = @_;
- my $all = {};
- my %subt;
-
- if ($self->get_unit($self->name) != $self) {
- Carp::confess "Local unit cache inconsistant";
- }
-
- $self->ns->visit_stashes(sub {
- my @path = @{ $_[0] };
- return unless @path;
- my $tag = join("", map { $_ . "::" } @path);
- my $st = $all->{$tag} = bless { '!id' => [$tag] }, 'Stash';
- my @ppath = @path;
- my $name = pop @ppath;
- my $ptag = join("", map { $_ . "::" } @ppath);
- if ($ptag ne '') {
- $st->{'PARENT::'} = [ $ptag ];
- $all->{$ptag}{$name . '::'} = $st;
- }
- for my $tok ($self->ns->list_stash(@path)) {
- if ($tok->[1] eq 'var') {
- my $name = $tok->[0];
- $st->{$name} = bless { name => $name }, 'NAME';
- $st->{'&' . $name} = $st->{$name} if $name !~ /^[\$\@\%\&]/;
- }
- }
- });
-
- my $top = $self->deref($self->bottom_ref // $self->mainline->xref);
- #say STDERR "Top = $top";
- for (my $cursor = $top; $cursor; $cursor = $cursor->outer) {
- my $id = _syml_myname($cursor->xref);
- #say STDERR "Creating $cursor [$id]";
- $subt{$cursor} = $all->{$id} = bless { '!id' => [ $id ] }, 'Stash';
- }
-
- for (my $cursor = $top; $cursor; $cursor = $cursor->outer) {
- my $st = $subt{$cursor};
- #say STDERR "Populating $cursor";
- for my $name (sort keys %{ $cursor->lexicals }) {
- my $lx = $cursor->lexicals->{$name};
- $st->{$name} = bless { name => $name }, 'NAME';
- $st->{'&' . $name} = $st->{$name} if $name !~ /^[\$\@\%\&]/;
-
- if ($lx->isa('Metamodel::Lexical::Stash')) {
- my @cpath = $self->ns->stash_canon(@{ $lx->path });
- $st->{$name . '::'} = $all->{join "", map { $_ . "::" }
- $self->ns->stash_canon(@cpath)};
- }
- }
- $st->{'OUTER::'} = $cursor->outer ? $subt{$cursor->outer}{'!id'} :
- [];
- if ($cursor->unit->bottom_ref && $cursor->unit->name eq 'CORE') {
- $all->{'CORE'} //= $st;
- }
- if ($cursor->unit->bottom_ref) {
- $all->{'SETTING'} //= $st;
- }
- }
- #say STDERR "UNIT ", $self->mainline;
- #$all->{'UNIT'} = $subt{$self->mainline};
- {
- my @nbits = @{ $self->mainline->find_pkg(['MY', split '::', $self->name]) };
- @nbits = $self->ns->stash_canon(@nbits);
- # XXX wrong, but makes STD importing work
- # say STDERR (YAML::XS::Dump @nbits);
- $all->{'UNIT'} = $all->{join "", map { $_ . '::' } @nbits};
- }
- # say STDERR (YAML::XS::Dump("Regenerated syml for " . $self->name, $all));
- $all;
- }
-
- no Moose;
- __PACKAGE__->meta->make_immutable;
-}
-
-
-### Code goes here to build up the metamodel from an Op tree
-# We should eventually wire this to the parser, so that metamodel stuff can
-# exist during the parse itself; will be needed for macros
-
-sub Unit::begin {
- my $self = shift;
- local $unit = Metamodel::Unit->new(name => $self->name,
- ns => Metamodel::Namespace->new,
- $::SETTING_UNIT ? (setting => $::SETTING_UNIT) : ());
- $units{$self->name} = $unit;
-
- $unit->need_unit($::SETTING_UNIT) if $::SETTING_UNIT;
-
- $unit->create_stash('GLOBAL');
- $unit->create_stash('PROCESS');
-
- local @opensubs;
- $unit->mainline($self->mainline->begin(once => 1,
- top => ($::SETTING_UNIT ? $unit->get_unit($::SETTING_UNIT)->bottom_ref : undef)));
-
- $unit;
-}
-
-my %type2phaser = ( init => 0, end => 1, begin => 2 );
-
-sub Body::begin {
- my $self = shift;
- my %args = @_;
-
- my $top = @opensubs ? $opensubs[-1]->xref : $args{top};
- my $rtop = !$top ? $top : $unit->deref($top);
-
- my $type = $self->type // '';
- my $metabody = Metamodel::StaticSub->new(
- unit => $unit,
- outer => $top,
- body_of => $args{body_of},
- in_class => $args{body_of} // (@opensubs ? $opensubs[-1]->in_class :
- undef),
- cur_pkg => $args{cur_pkg} // (@opensubs ? $opensubs[-1]->cur_pkg :
- [ 'GLOBAL' ]), # cur_pkg does NOT propagate down from settings
- augmenting => $args{augmenting},
- name => ($args{prefix} // '') . $self->name,
- returnable => $self->returnable,
- gather_hack=> $args{gather_hack},
- augment_hack=> $args{augment_hack},
- is_phaser => $type2phaser{$type},
- class => $self->class,
- ltm => $self->ltm,
- run_once => $args{once} && (!@opensubs || $rtop->run_once));
-
- $unit->create_stash(@{ $metabody->cur_pkg });
-
- push @opensubs, $metabody; # always visible in the signature XXX
-
- if ($self->signature) {
- $self->signature->begin;
- $metabody->signature($self->signature);
- }
-
- if ($type && $type eq 'regex') {
- $metabody->add_my_name('$*/');
- }
-
- pop @opensubs if $self->transparent;
-
- my $do = $self->do;
-
- $do->begin;
- $metabody->code($do);
-
- $metabody->close;
- pop @opensubs unless $self->transparent;
-
- $metabody;
-}
-
-sub Sig::begin {
- my $self = shift;
-
- $_->begin for @{ $self->params };
-}
-
-sub Sig::Parameter::begin {
- my $self = shift;
-
- $opensubs[-1]->add_my_name($self->slot, list => $self->list,
- hash => $self->hash, noinit => 1) if defined $self->slot;
- if (defined ($self->default)) {
- my $mdefault = $self->default->begin;
- $self->mdefault($mdefault->xref);
- $opensubs[-1]->add_child($mdefault);
- delete $self->{default};
- }
-}
-
-sub Op::begin {
- my $self = shift;
-
- $_->begin for $self->zyg;
-}
-
-sub Op::YouAreHere::begin {
- my $self = shift;
- $unit->bottom_ref($opensubs[-1]->xref);
- $opensubs[-1]->strong_used(1);
- $opensubs[-1]->create_static_pad;
-}
-
-sub Op::Use::begin {
- my $self = shift;
- my $name = $self->unit;
- my $u2 = $unit->need_unit($self->unit);
-
- my @can = @{ $u2->mainline->find_pkg(['MY', split /::/, $name]) };
- my @exp = (@can, 'EXPORT', 'DEFAULT');
- my @zyg = $unit->list_stash(@exp);
-
- # XXX I am not sure how need binding should work in the :: case
- if ($name !~ /::/) {
- $opensubs[-1]->lexicals->{$name} =
- Metamodel::Lexical::Stash->new(path => [@can]);
- }
-
- for my $tup (@zyg) {
- my $uname = $tup->[0];
- my $lex;
- if ($tup->[1] eq 'var') {
- if ($tup->[2] && !$tup->[2][0]) {
- $lex = Metamodel::Lexical::Common->new(path => [@exp], name => $uname);
- } elsif ($tup->[2]) {
- $lex = Metamodel::Lexical::Stash->new(path => [@exp, $uname]);
- }
- } elsif ($tup->[1] eq 'graft') {
- $lex = Metamodel::Lexical::Stash->new(path => $tup->[2]);
- } else {
- die "weird return";
- }
-
- $opensubs[-1]->lexicals->{$uname} = $lex;
- }
-}
-
-sub Op::Lexical::begin {
- my $self = shift;
-
- if ($self->state_backing) {
- $opensubs[-1]->add_state_name($self->name, $self->state_backing,
- list => $self->list, hash => $self->hash);
- } elsif ($self->declaring) {
- $opensubs[-1]->add_my_name($self->name, list => $self->list,
- hash =>$self->hash);
- }
-}
-
-sub Op::CallMethod::begin {
- my $self = shift;
-
- $self->Op::begin;
- if ($self->private) {
- if ($self->ppath) {
- $self->pclass($unit->get_item(@{ $opensubs[-1]->find_pkg($self->ppath) }));
- } elsif ($opensubs[-1]->in_class) {
- $self->pclass($opensubs[-1]->in_class);
- } else {
- die "unable to resolve class of reference for method";