Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

* Import Pugs 6.2.13.15 from Hackage.

  • Loading branch information...
commit 1384f0b3765db68557b5ee2e2cef2417f5562a82 0 parents
@audreyt audreyt authored
Showing with 96,888 additions and 0 deletions.
  1. +93 −0 Pugs/Configure.PL
  2. +20 −0 Pugs/LICENSE
  3. +184 −0 Pugs/Pugs.cabal
  4. +8 −0 Pugs/Setup.lhs
  5. +512 −0 Pugs/blib6/pugs/perl5/lib/Parse/Yapp.pm
  6. +471 −0 Pugs/blib6/pugs/perl5/lib/Parse/Yapp/Driver.pm
  7. +381 −0 Pugs/blib6/pugs/perl5/lib/Parse/Yapp/Grammar.pm
  8. +939 −0 Pugs/blib6/pugs/perl5/lib/Parse/Yapp/Lalr.pm
  9. +186 −0 Pugs/blib6/pugs/perl5/lib/Parse/Yapp/Options.pm
  10. +92 −0 Pugs/blib6/pugs/perl5/lib/Parse/Yapp/Output.pm
  11. +1,093 −0 Pugs/blib6/pugs/perl5/lib/Parse/Yapp/Parse.pm
  12. +36 −0 Pugs/blib6/pugs/perl5/lib/Pugs/AST/Expression.pm
  13. +120 −0 Pugs/blib6/pugs/perl5/lib/Pugs/Compiler/Grammar.pm
  14. +506 −0 Pugs/blib6/pugs/perl5/lib/Pugs/Compiler/Regex.pm
  15. +123 −0 Pugs/blib6/pugs/perl5/lib/Pugs/Compiler/RegexPerl5.pm
  16. +219 −0 Pugs/blib6/pugs/perl5/lib/Pugs/Compiler/Rule.pm
  17. +48 −0 Pugs/blib6/pugs/perl5/lib/Pugs/Compiler/Token.pm
  18. +169 −0 Pugs/blib6/pugs/perl5/lib/Pugs/Emitter/Grammar/Perl5.pm
  19. +405 −0 Pugs/blib6/pugs/perl5/lib/Pugs/Emitter/Rule/Parsec.pm
  20. +611 −0 Pugs/blib6/pugs/perl5/lib/Pugs/Emitter/Rule/Perl5.pm
  21. +140 −0 Pugs/blib6/pugs/perl5/lib/Pugs/Emitter/Rule/Perl5/CharClass.pm
  22. +1,152 −0 Pugs/blib6/pugs/perl5/lib/Pugs/Emitter/Rule/Perl5/Ratchet.pm
  23. +250 −0 Pugs/blib6/pugs/perl5/lib/Pugs/Emitter/Rule/Perl5/Regex.pm
  24. +854 −0 Pugs/blib6/pugs/perl5/lib/Pugs/Emitter/Rule/Perl6/Ratchet.pm
  25. +201 −0 Pugs/blib6/pugs/perl5/lib/Pugs/Grammar/Base.pm
  26. +349 −0 Pugs/blib6/pugs/perl5/lib/Pugs/Grammar/Precedence.pm
  27. +3 −0  Pugs/blib6/pugs/perl5/lib/Pugs/Grammar/Rule.pm
  28. +15,209 −0 Pugs/blib6/pugs/perl5/lib/Pugs/Grammar/Rule.pmc
  29. +608 −0 Pugs/blib6/pugs/perl5/lib/Pugs/Grammar/Rule2.pm
  30. +263 −0 Pugs/blib6/pugs/perl5/lib/Pugs/Grammar/RulePure.pm
  31. +62 −0 Pugs/blib6/pugs/perl5/lib/Pugs/Runtime/Common.pm
  32. +309 −0 Pugs/blib6/pugs/perl5/lib/Pugs/Runtime/Match.pm
  33. +83 −0 Pugs/blib6/pugs/perl5/lib/Pugs/Runtime/Match/HsBridge.pm
  34. +830 −0 Pugs/blib6/pugs/perl5/lib/Pugs/Runtime/Regex.pm
  35. +5 −0 Pugs/blib6/pugs/perl5/lib/Pugs/Runtime/Rule.pm
  36. +230 −0 Pugs/blib6/pugs/perl5/lib/Pugs/Runtime/StrPos.pm
  37. +124 −0 Pugs/blib6/pugs/perl5/lib/Pugs/Runtime/Tracer.pm
  38. +29,854 −0 Pugs/cbits/Prelude_pm.c
  39. +21,019 −0 Pugs/cbits/Test_pm.c
  40. +590 −0 Pugs/perl5/p5embed.c
  41. +30 −0 Pugs/perl5/p5embed.h
  42. +16 −0 Pugs/perl5/perlxsi.c
  43. +144 −0 Pugs/perl5/pugsembed.c
  44. +33 −0 Pugs/perl5/pugsembed.h
  45. +20 −0 Pugs/src/Main.hs
  46. +478 −0 Pugs/src/Pugs.hs
  47. +484 −0 Pugs/src/Pugs/AST.hs
  48. +9 −0 Pugs/src/Pugs/AST.hs-boot
  49. +210 −0 Pugs/src/Pugs/AST/Eval.hs
  50. +236 −0 Pugs/src/Pugs/AST/Functions.hs
  51. +1,340 −0 Pugs/src/Pugs/AST/Internals.hs
  52. +67 −0 Pugs/src/Pugs/AST/Internals.hs-boot
  53. +1,474 −0 Pugs/src/Pugs/AST/Internals/Instances.hs
  54. +103 −0 Pugs/src/Pugs/AST/Pad.hs
  55. +27 −0 Pugs/src/Pugs/AST/Pos.hs
  56. +26 −0 Pugs/src/Pugs/AST/Prag.hs
  57. +81 −0 Pugs/src/Pugs/AST/SIO.hs
  58. +14 −0 Pugs/src/Pugs/AST/Scope.hs
  59. +457 −0 Pugs/src/Pugs/AST/Types.hs
  60. +173 −0 Pugs/src/Pugs/AST/Utils.hs
  61. +270 −0 Pugs/src/Pugs/Bind.hs
  62. +178 −0 Pugs/src/Pugs/Class.hs
  63. +102 −0 Pugs/src/Pugs/CodeGen.hs
  64. +16 −0 Pugs/src/Pugs/CodeGen/Binary.hs
  65. +14 −0 Pugs/src/Pugs/CodeGen/JSON.hs
  66. +17 −0 Pugs/src/Pugs/CodeGen/PIL1.hs
  67. +455 −0 Pugs/src/Pugs/CodeGen/PIR.hs
  68. +153 −0 Pugs/src/Pugs/CodeGen/PIR/Prelude.hs
  69. +14 −0 Pugs/src/Pugs/CodeGen/Perl5.hs
  70. +28 −0 Pugs/src/Pugs/CodeGen/YAML.hs
  71. +459 −0 Pugs/src/Pugs/Compile.hs
  72. +228 −0 Pugs/src/Pugs/Compile/Pugs.hs
  73. +74 −0 Pugs/src/Pugs/Config.hs
  74. +47 −0 Pugs/src/Pugs/Cont.hs
  75. +37 −0 Pugs/src/Pugs/Embed.hs
  76. +29 −0 Pugs/src/Pugs/Embed/Haskell.hs
  77. +133 −0 Pugs/src/Pugs/Embed/Parrot.hs
  78. +382 −0 Pugs/src/Pugs/Embed/Perl5.hs
  79. +17 −0 Pugs/src/Pugs/Embed/Pugs.hs
  80. +1,586 −0 Pugs/src/Pugs/Eval.hs
  81. +652 −0 Pugs/src/Pugs/Eval/Var.hs
  82. +74 −0 Pugs/src/Pugs/Exp.hs
  83. +9 −0 Pugs/src/Pugs/Exp.hs-boot
  84. +52 −0 Pugs/src/Pugs/External.hs
  85. +121 −0 Pugs/src/Pugs/External/Haskell.hs
  86. +90 −0 Pugs/src/Pugs/Help.hs
  87. +18 −0 Pugs/src/Pugs/Internals.hs
  88. +228 −0 Pugs/src/Pugs/Junc.hs
  89. +572 −0 Pugs/src/Pugs/Lexer.hs
  90. +25 −0 Pugs/src/Pugs/Meta.hs
  91. +15 −0 Pugs/src/Pugs/Meta/Class.hs
  92. +60 −0 Pugs/src/Pugs/Meta/Perl5.hs
  93. +37 −0 Pugs/src/Pugs/Meta/Str.hs
  94. +430 −0 Pugs/src/Pugs/Monads.hs
  95. +123 −0 Pugs/src/Pugs/PIL1.hs
  96. +373 −0 Pugs/src/Pugs/PIL1/Instances.hs
  97. +2,138 −0 Pugs/src/Pugs/Parser.hs
  98. +24 −0 Pugs/src/Pugs/Parser.hs-boot
  99. +297 −0 Pugs/src/Pugs/Parser/Charnames.hs
  100. +105 −0 Pugs/src/Pugs/Parser/Doc.hs
  101. +24 −0 Pugs/src/Pugs/Parser/Export.hs
  102. +686 −0 Pugs/src/Pugs/Parser/Literal.hs
  103. +111 −0 Pugs/src/Pugs/Parser/Number.hs
  104. +752 −0 Pugs/src/Pugs/Parser/Operator.hs
  105. +210 −0 Pugs/src/Pugs/Parser/Program.hs
  106. +382 −0 Pugs/src/Pugs/Parser/Types.hs
  107. +108 −0 Pugs/src/Pugs/Parser/Unsafe.hs
  108. +306 −0 Pugs/src/Pugs/Parser/Util.hs
  109. +854 −0 Pugs/src/Pugs/Prelude.hs
Sorry, we could not display the entire diff because it was too big.
93 Pugs/Configure.PL
@@ -0,0 +1,93 @@
+#!/usr/bin/perl
+
+use 5.006;
+use strict;
+use Cwd;
+use Config;
+use ExtUtils::Embed;
+
+my $embed_flags = "-I" . cwd();
+my $ccdlflags = "";
+my $flags = "$Config{ccflags} $Config{ccdlflags} ";
+
+if ($flags =~ /\S/) {
+ $flags =~ s{([\\"'])}{\\$1}g;
+ my @flags = grep { length $_ } split /\s+/, $flags;
+
+ if ($^O eq 'MSWin32') {
+ if ($Config{libperl} =~ /lib(\w+)\.a/) {
+ $embed_flags .= " -optl-l$1 ";
+ }
+ elsif (defined &Win32::BuildNumber) {
+ # We are on ActivePerl -- Kluge massively!
+
+ no warnings 'once';
+ our %MY_CONFIG = %Config;
+ *Config = *MY_CONFIG;
+ *Config::Config = *MY_CONFIG;
+ *ExtUtils::MM_Win32::Config = *MY_CONFIG;
+ *ExtUtils::MM_Unix::Config = *MY_CONFIG;
+
+ $Config{ccflags} =~ s/-libpath:"?(.*?)"? //g;
+ $Config{ccdlflags} =~ s/-libpath:"?(.*?)"? //g;
+ $Config{lddlflags} =~ s/-libpath:"?(.*?)"? //g;
+ $Config{ldflags} =~ s/-libpath:"?(.*?)"? //g
+ or die "ldflags: $Config{ldflags} does not contain -libpath:";
+
+ my $lib = "$1/$Config{libperl}";
+ $embed_flags .= " -optl\"$lib\" ";
+
+ $flags = "$Config{ccflags} $Config{ccdlflags}";
+ $flags =~ s{([\\"'])}{\\$1}g;
+ @flags = grep { length $_ } split /\s+/, $flags;
+ }
+ else {
+ warn "Unrecognized libperl shared library: $Config{libperl}, proceeding anyway...\n";
+ }
+
+ $ccdlflags .= (/^-[DIL]/ ? ' -optc' : ' -optl') . qq["$_" ] for @flags;
+ $embed_flags .= " -optc-Ddirent=DIRENT";
+ }
+ else {
+ $embed_flags .= " -optc$_" for grep length, split(/\s+/, ccopts());
+ $embed_flags .= " -optl$_" for grep length, split(/\s+/, ldopts());
+ }
+
+ $embed_flags .= " $_" for grep { /-[DIL]/ } split(/\s+/, ccopts());
+ $embed_flags .= " $_" for grep { /-[DIL]/ } split(/\s+/, ldopts());
+
+ if ($Config{osname} eq 'cygwin') {
+ my $cygpath = sub {
+ my $path = `cygpath -m @_`;
+ chomp $path;
+ return $path;
+ };
+ $embed_flags =~ s{(/usr/\S+)}{$cygpath->($1)}eg;
+ $embed_flags =~ s{/cygdrive/(\w)/}{$1:/}g;
+ #warn "** Cygwin embedding flags: embed_flags\n";
+ }
+}
+
+my @include_dirs = split(/\s+/, perl_inc());
+s/^-I// for @include_dirs;
+
+my @cc_options = map { /^-optc(.+)/ ? $1 : () } (split(/\s+/, $embed_flags), split(/\s+/, $ccdlflags));
+my @ld_options = grep { not /,/ } map { /^-optl(.+)/ ? $1 : () } (split(/\s+/, $embed_flags), split(/\s+/, $ccdlflags));
+
+my $info = << ".";
+executable: pugs
+ghc-options: $embed_flags $ccdlflags
+include-dirs: @include_dirs
+cc-options: @cc_options
+ld-options: @ld_options
+.
+
+# Hack for OSX 10.6
+$info =~ s/-arch x86_64 (-arch i386) -arch ppc/$1/g;
+$info =~ s/-opt[lc]-arch -opt[lc]x86_64 (-opt[lc]-arch -opt[lc]i386) -opt[lc]-arch -opt[lc]ppc/$1/g;
+
+open INFO, ">Pugs.buildinfo" or die "Cannot write build info: $!";
+print INFO $info;
+close INFO;
+
+xsinit();
20 Pugs/LICENSE
@@ -0,0 +1,20 @@
+The "MIT" License
+
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
+
+The above copyright notice and this permission notice shall be
+included in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
184 Pugs/Pugs.cabal
@@ -0,0 +1,184 @@
+Name : Pugs
+Version : 6.2.13.15
+license : BSD3
+license-file : LICENSE
+cabal-version : >= 1.2.3
+copyright : 2005-2008, The Pugs Contributors
+maintainer : Audrey Tang <audreyt@audreyt.org>
+category : Language, Pugs
+stability : experimental
+build-type : Custom
+homepage : http://pugscode.org/
+synopsis : A Perl 6 Implementation
+description : A Perl 6 Implementation
+author : Audrey Tang <audreyt@audreyt.org>
+Tested-With: GHC==6.8.2, GHC==6.8.3, GHC==6.10.1, GHC==6.12.1
+data-files :
+ blib6/pugs/perl5/lib/Parse/Yapp/Driver.pm
+ blib6/pugs/perl5/lib/Parse/Yapp/Grammar.pm
+ blib6/pugs/perl5/lib/Parse/Yapp/Lalr.pm
+ blib6/pugs/perl5/lib/Parse/Yapp/Options.pm
+ blib6/pugs/perl5/lib/Parse/Yapp/Output.pm
+ blib6/pugs/perl5/lib/Parse/Yapp/Parse.pm
+ blib6/pugs/perl5/lib/Parse/Yapp.pm
+ blib6/pugs/perl5/lib/Pugs/AST/Expression.pm
+ blib6/pugs/perl5/lib/Pugs/Compiler/Grammar.pm
+ blib6/pugs/perl5/lib/Pugs/Compiler/Regex.pm
+ blib6/pugs/perl5/lib/Pugs/Compiler/RegexPerl5.pm
+ blib6/pugs/perl5/lib/Pugs/Compiler/Rule.pm
+ blib6/pugs/perl5/lib/Pugs/Compiler/Token.pm
+ blib6/pugs/perl5/lib/Pugs/Emitter/Grammar/Perl5.pm
+ blib6/pugs/perl5/lib/Pugs/Emitter/Rule/Parsec.pm
+ blib6/pugs/perl5/lib/Pugs/Emitter/Rule/Perl5/CharClass.pm
+ blib6/pugs/perl5/lib/Pugs/Emitter/Rule/Perl5/Ratchet.pm
+ blib6/pugs/perl5/lib/Pugs/Emitter/Rule/Perl5/Regex.pm
+ blib6/pugs/perl5/lib/Pugs/Emitter/Rule/Perl5.pm
+ blib6/pugs/perl5/lib/Pugs/Emitter/Rule/Perl6/Ratchet.pm
+ blib6/pugs/perl5/lib/Pugs/Grammar/Base.pm
+ blib6/pugs/perl5/lib/Pugs/Grammar/Precedence.pm
+ blib6/pugs/perl5/lib/Pugs/Grammar/Rule.pm
+ blib6/pugs/perl5/lib/Pugs/Grammar/Rule.pmc
+ blib6/pugs/perl5/lib/Pugs/Grammar/Rule2.pm
+ blib6/pugs/perl5/lib/Pugs/Grammar/RulePure.pm
+ blib6/pugs/perl5/lib/Pugs/Runtime/Common.pm
+ blib6/pugs/perl5/lib/Pugs/Runtime/Match/HsBridge.pm
+ blib6/pugs/perl5/lib/Pugs/Runtime/Match.pm
+ blib6/pugs/perl5/lib/Pugs/Runtime/Regex.pm
+ blib6/pugs/perl5/lib/Pugs/Runtime/Rule.pm
+ blib6/pugs/perl5/lib/Pugs/Runtime/StrPos.pm
+ blib6/pugs/perl5/lib/Pugs/Runtime/Tracer.pm
+extra-source-files:
+ src/Pugs.hs
+ src/Pugs/AST.hs
+ src/Pugs/AST.hs-boot
+ src/Pugs/AST/Eval.hs
+ src/Pugs/AST/Functions.hs
+ src/Pugs/AST/Internals.hs
+ src/Pugs/AST/Internals.hs-boot
+ src/Pugs/AST/Internals/Instances.hs
+ src/Pugs/AST/Pad.hs
+ src/Pugs/AST/Pos.hs
+ src/Pugs/AST/Prag.hs
+ src/Pugs/AST/SIO.hs
+ src/Pugs/AST/Scope.hs
+ src/Pugs/AST/Utils.hs
+ src/Pugs/AST/Types.hs
+ src/Pugs/Bind.hs
+ src/Pugs/Class.hs
+ src/Pugs/CodeGen.hs
+ src/Pugs/CodeGen/JSON.hs
+ src/Pugs/CodeGen/PIL1.hs
+ src/Pugs/CodeGen/PIR.hs
+ src/Pugs/CodeGen/PIR/Prelude.hs
+ src/Pugs/CodeGen/Perl5.hs
+ src/Pugs/CodeGen/YAML.hs
+ src/Pugs/CodeGen/Binary.hs
+ src/Pugs/Compile.hs
+ src/Pugs/Compile/Pugs.hs
+ src/Pugs/Config.hs
+ src/Pugs/Cont.hs
+ src/Pugs/Embed.hs
+ src/Pugs/Embed/Haskell.hs
+ src/Pugs/Embed/Parrot.hs
+ src/Pugs/Embed/Perl5.hs
+ src/Pugs/Embed/Pugs.hs
+ src/Pugs/Eval.hs
+ src/Pugs/Eval/Var.hs
+ src/Pugs/Exp.hs
+ src/Pugs/Exp.hs-boot
+ src/Pugs/External.hs
+ src/Pugs/External/Haskell.hs
+ src/Pugs/Help.hs
+ src/Pugs/Internals.hs
+ src/Pugs/Junc.hs
+ src/Pugs/Lexer.hs
+ src/Pugs/Meta.hs
+ src/Pugs/Meta/Class.hs
+ src/Pugs/Meta/Perl5.hs
+ src/Pugs/Meta/Str.hs
+ src/Pugs/Monads.hs
+ src/Pugs/PIL1.hs
+ src/Pugs/PIL1/Instances.hs
+ src/Pugs/Parser.hs
+ src/Pugs/Parser.hs-boot
+ src/Pugs/Parser/Charnames.hs
+ src/Pugs/Parser/Doc.hs
+ src/Pugs/Parser/Export.hs
+ src/Pugs/Parser/Literal.hs
+ src/Pugs/Parser/Number.hs
+ src/Pugs/Parser/Operator.hs
+ src/Pugs/Parser/Program.hs
+ src/Pugs/Parser/Types.hs
+ src/Pugs/Parser/Unsafe.hs
+ src/Pugs/Parser/Util.hs
+ src/Pugs/Prelude.hs
+ src/Pugs/Pretty.hs
+ src/Pugs/Prim.hs
+ src/Pugs/Prim/Code.hs
+ src/Pugs/Prim/Eval.hs
+ src/Pugs/Prim/FileTest.hs
+ src/Pugs/Prim/Keyed.hs
+ src/Pugs/Prim/Lifts.hs
+ src/Pugs/Prim/List.hs
+ src/Pugs/Prim/Match.hs
+ src/Pugs/Prim/Numeric.hs
+ src/Pugs/Prim/Param.hs
+ src/Pugs/Prim/Yaml.hs
+ src/Pugs/Rule.hs
+ src/Pugs/Run.hs
+ src/Pugs/Run/Args.hs
+ src/Pugs/Run/Perl5.hs
+ src/Pugs/Shell.hs
+ src/Pugs/Types.hs
+ src/Pugs/Types/Array.hs
+ src/Pugs/Types/Code.hs
+ src/Pugs/Types/Handle.hs
+ src/Pugs/Types/Hash.hs
+ src/Pugs/Types/Object.hs
+ src/Pugs/Types/Pair.hs
+ src/Pugs/Types/Rule.hs
+ src/Pugs/Types/Scalar.hs
+ src/Pugs/Types/Thunk.hs
+ src/Pugs/Val.hs
+ src/Pugs/Val/Base.hs
+ src/Pugs/Val/Capture.hs
+ src/Pugs/Val/Code.hs
+ src/Pugs/Version.hs
+ Configure.PL
+ perl5/p5embed.c
+ perl5/p5embed.h
+ perl5/perlxsi.c
+ perl5/pugsembed.c
+ perl5/pugsembed.h
+
+flag Perl5
+ description: Enable Perl 5 Embedding
+ default: True
+
+executable pugs
+ main-is: Main.hs
+ hs-source-dirs: src
+
+ build-depends:
+ base >= 3 && < 5, haskell98, filepath, mtl, stm, parsec < 3.0.0, network,
+ pretty, time, random, process, containers, bytestring,
+ array, directory, utf8-string, binary, haskeline >= 0.2.1, FindBin,
+ control-timeout >= 0.1.2,
+
+ MetaObject >= 0.0.4,
+ HsParrot >= 0.0.2,
+ pugs-compat >= 0.0.5,
+ pugs-DrIFT >= 2.2.3.0,
+ stringtable-atom >= 0.0.4,
+ HsSyck >= 0.44
+ -- HsPerl5
+
+ if flag(Perl5)
+ cpp-options: -DPUGS_HAVE_PERL5=1
+
+ c-sources:
+ cbits/Prelude_pm.c cbits/Test_pm.c
+ perl5/p5embed.c
+
+ includes:
+ perl5/p5embed.h
8 Pugs/Setup.lhs
@@ -0,0 +1,8 @@
+#!/usr/bin/env runghc
+> import Distribution.Simple
+> import System.Cmd (rawSystem)
+>
+> main :: IO ()
+> main = writeBuildInfo >> defaultMainWithHooks defaultUserHooks
+> where
+> writeBuildInfo = rawSystem "perl" ["Configure.PL"]
512 Pugs/blib6/pugs/perl5/lib/Parse/Yapp.pm
@@ -0,0 +1,512 @@
+#
+# Module Parse::Yapp.pm.
+#
+# Copyright (c) 1998-2001, Francois Desarmenien, all right reserved.
+#
+# See the Copyright section at the end of the Parse/Yapp.pm pod section
+# for usage and distribution rights.
+#
+#
+package Parse::Yapp;
+
+use strict;
+use vars qw($VERSION @ISA);
+@ISA = qw(Parse::Yapp::Output);
+
+use Parse::Yapp::Output;
+
+# $VERSION is in Parse/Yapp/Driver.pm
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+Parse::Yapp - Perl extension for generating and using LALR parsers.
+
+=head1 SYNOPSIS
+
+ yapp -m MyParser grammar_file.yp
+
+ ...
+
+ use MyParser;
+
+ $parser=new MyParser();
+ $value=$parser->YYParse(yylex => \&lexer_sub, yyerror => \&error_sub);
+
+ $nberr=$parser->YYNberr();
+
+ $parser->YYData->{DATA}= [ 'Anything', 'You Want' ];
+
+ $data=$parser->YYData->{DATA}[0];
+
+=head1 DESCRIPTION
+
+Parse::Yapp (Yet Another Perl Parser compiler) is a collection of modules
+that let you generate and use yacc like thread safe (reentrant) parsers with
+perl object oriented interface.
+
+The script yapp is a front-end to the Parse::Yapp module and let you
+easily create a Perl OO parser from an input grammar file.
+
+=head2 The Grammar file
+
+=over 4
+
+=item C<Comments>
+
+Through all your files, comments are either Perl style, introduced by I<#>
+up to the end of line, or C style, enclosed between I</*> and I<*/>.
+
+
+=item C<Tokens and string literals>
+
+
+Through all the grammar files, two kind of symbols may appear:
+I<Non-terminal> symbols, called also I<left-hand-side> symbols,
+which are the names of your rules, and I<Terminal> symbols, called
+also I<Tokens>.
+
+Tokens are the symbols your lexer function will feed your parser with
+(see below). They are of two flavours: symbolic tokens and string
+literals.
+
+Non-terminals and symbolic tokens share the same identifier syntax:
+
+ [A-Za-z][A-Za-z0-9_]*
+
+String literals are enclosed in single quotes and can contain almost
+anything. They will be output to your parser file double-quoted, making
+any special character as such. '"', '$' and '@' will be automatically
+quoted with '\', making their writing more natural. On the other hand,
+if you need a single quote inside your literal, just quote it with '\'.
+
+You cannot have a literal I<'error'> in your grammar as it would
+confuse the driver with the I<error> token. Use a symbolic token instead.
+In case you inadvertently use it, this will produce a warning telling you
+you should have written it I<error> and will treat it as if it were the
+I<error> token, which is certainly NOT what you meant.
+
+
+=item C<Grammar file syntax>
+
+It is very close to yacc syntax (in fact, I<Parse::Yapp> should compile
+a clean I<yacc> grammar without any modification, whereas the opposite
+is not true).
+
+This file is divided in three sections, separated by C<%%>:
+
+ header section
+ %%
+ rules section
+ %%
+ footer section
+
+=over 4
+
+=item B<The Header Section> section may optionally contain:
+
+=item *
+
+One or more code blocks enclosed inside C<%{> and C<%}> just like in
+yacc. They may contain any valid Perl code and will be copied verbatim
+at the very beginning of the parser module. They are not as useful as
+they are in yacc, but you can use them, for example, for global variable
+declarations, though you will notice later that such global variables can
+be avoided to make a reentrant parser module.
+
+=item *
+
+Precedence declarations, introduced by C<%left>, C<%right> and C<%nonassoc>
+specifying associativity, followed by the list of tokens or litterals
+having the same precedence and associativity.
+The precedence beeing the latter declared will be having the highest level.
+(see the yacc or bison manuals for a full explanation of how they work,
+as they are implemented exactly the same way in Parse::Yapp)
+
+=item *
+
+C<%start> followed by a rule's left hand side, declaring this rule to
+be the starting rule of your grammar. The default, when C<%start> is not
+used, is the first rule in your grammar section.
+
+=item *
+
+C<%token> followed by a list of symbols, forcing them to be recognized
+as tokens, generating a syntax error if used in the left hand side of
+a rule declaration.
+Note that in Parse::Yapp, you I<don't> need to declare tokens as in yacc: any
+symbol not appearing as a left hand side of a rule is considered to be
+a token.
+Other yacc declarations or constructs such as C<%type> and C<%union> are
+parsed but (almost) ignored.
+
+=item *
+
+C<%expect> followed by a number, suppress warnings about number of Shift/Reduce
+conflicts when both numbers match, a la bison.
+
+
+=item B<The Rule Section> contains your grammar rules:
+
+A rule is made of a left-hand-side symbol, followed by a C<':'> and one
+or more right-hand-sides separated by C<'|'> and terminated by a C<';'>:
+
+ exp: exp '+' exp
+ | exp '-' exp
+ ;
+
+A right hand side may be empty:
+
+ input: #empty
+ | input line
+ ;
+
+(if you have more than one empty rhs, Parse::Yapp will issue a warning,
+as this is usually a mistake, and you will certainly have a reduce/reduce
+conflict)
+
+
+A rhs may be followed by an optional C<%prec> directive, followed
+by a token, giving the rule an explicit precedence (see yacc manuals
+for its precise meaning) and optionnal semantic action code block (see
+below).
+
+ exp: '-' exp %prec NEG { -$_[1] }
+ | exp '+' exp { $_[1] + $_[3] }
+ | NUM
+ ;
+
+Note that in Parse::Yapp, a lhs I<cannot> appear more than once as
+a rule name (This differs from yacc).
+
+
+=item C<The footer section>
+
+may contain any valid Perl code and will be appended at the very end
+of your parser module. Here you can write your lexer, error report
+subs and anything relevant to you parser.
+
+=item C<Semantic actions>
+
+Semantic actions are run every time a I<reduction> occurs in the
+parsing flow and they must return a semantic value.
+
+They are (usually, but see below C<In rule actions>) written at
+the very end of the rhs, enclosed with C<{ }>, and are copied verbatim
+to your parser file, inside of the rules table.
+
+Be aware that matching braces in Perl is much more difficult than
+in C: inside strings they don't need to match. While in C it is
+very easy to detect the beginning of a string construct, or a
+single character, it is much more difficult in Perl, as there
+are so many ways of writing such literals. So there is no check
+for that today. If you need a brace in a double-quoted string, just
+quote it (C<\{> or C<\}>). For single-quoted strings, you will need
+to make a comment matching it I<in th right order>.
+Sorry for the inconvenience.
+
+ {
+ "{ My string block }".
+ "\{ My other string block \}".
+ qq/ My unmatched brace \} /.
+ # Force the match: {
+ q/ for my closing brace } /
+ q/ My opening brace { /
+ # must be closed: }
+ }
+
+All of these constructs should work.
+
+
+In Parse::Yapp, semantic actions are called like normal Perl sub calls,
+with their arguments passed in C<@_>, and their semantic value are
+their return values.
+
+$_[1] to $_[n] are the parameters just as $1 to $n in yacc, while
+$_[0] is the parser object itself.
+
+Having $_[0] beeing the parser object itself allows you to call
+parser methods. Thats how the yacc macros are implemented:
+
+ yyerrok is done by calling $_[0]->YYErrok
+ YYERROR is done by calling $_[0]->YYError
+ YYACCEPT is done by calling $_[0]->YYAccept
+ YYABORT is done by calling $_[0]->YYAbort
+
+All those methods explicitly return I<undef>, for convenience.
+
+ YYRECOVERING is done by calling $_[0]->YYRecovering
+
+Four useful methods in error recovery sub
+
+ $_[0]->YYCurtok
+ $_[0]->YYCurval
+ $_[0]->YYExpect
+ $_[0]->YYLexer
+
+return respectivly the current input token that made the parse fail,
+its semantic value (both can be used to modify their values too, but
+I<know what you are doing> ! See I<Error reporting routine> section for
+an example), a list which contains the tokens the parser expected when
+the failure occured and a reference to the lexer routine.
+
+Note that if C<$_[0]-E<gt>YYCurtok> is declared as a C<%nonassoc> token,
+it can be included in C<$_[0]-E<gt>YYExpect> list whenever the input
+try to use it in an associative way. This is not a bug: the token
+IS expected to report an error if encountered.
+
+To detect such a thing in your error reporting sub, the following
+example should do the trick:
+
+ grep { $_[0]->YYCurtok eq $_ } $_[0]->YYExpect
+ and do {
+ #Non-associative token used in an associative expression
+ };
+
+Accessing semantics values on the left of your reducing rule is done
+through the method
+
+ $_[0]->YYSemval( index )
+
+where index is an integer. Its value being I<1 .. n> returns the same values
+than I<$_[1] .. $_[n]>, but I<-n .. 0> returns values on the left of the rule
+beeing reduced (It is related to I<$-n .. $0 .. $n> in yacc, but you
+cannot use I<$_[0]> or I<$_[-n]> constructs in Parse::Yapp for obvious reasons)
+
+
+There is also a provision for a user data area in the parser object,
+accessed by the method:
+
+ $_[0]->YYData
+
+which returns a reference to an anonymous hash, which let you have
+all of your parsing data held inside the object (see the Calc.yp
+or ParseYapp.yp files in the distribution for some examples).
+That's how you can make you parser module reentrant: all of your
+module states and variables are held inside the parser object.
+
+Note: unfortunatly, method calls in Perl have a lot of overhead,
+ and when YYData is used, it may be called a huge number
+ of times. If your are not a *real* purist and efficiency
+ is your concern, you may access directly the user-space
+ in the object: $parser->{USER} wich is a reference to an
+ anonymous hash array, and then benchmark.
+
+If no action is specified for a rule, the equivalant of a default
+action is run, which returns the first parameter:
+
+ { $_[1] }
+
+=item C<In rule actions>
+
+It is also possible to embed semantic actions inside of a rule:
+
+ typedef: TYPE { $type = $_[1] } identlist { ... } ;
+
+When the Parse::Yapp's parser encounter such an embedded action, it modifies
+the grammar as if you wrote (although @x-1 is not a legal lhs value):
+
+ @x-1: /* empty */ { $type = $_[1] };
+ typedef: TYPE @x-1 identlist { ... } ;
+
+where I<x> is a sequential number incremented for each "in rule" action,
+and I<-1> represents the "dot position" in the rule where the action arises.
+
+In such actions, you can use I<$_[1]..$_[n]> variables, which are the
+semantic values on the left of your action.
+
+Be aware that the way Parse::Yapp modifies your grammar because of
+I<in rule actions> can produce, in some cases, spurious conflicts
+that wouldn't happen otherwise.
+
+=item C<Generating the Parser Module>
+
+Now that you grammar file is written, you can use yapp on it
+to generate your parser module:
+
+ yapp -v Calc.yp
+
+will create two files F<Calc.pm>, your parser module, and F<Calc.output>
+a verbose output of your parser rules, conflicts, warnings, states
+and summary.
+
+What your are missing now is a lexer routine.
+
+=item C<The Lexer sub>
+
+is called each time the parser need to read the next token.
+
+It is called with only one argument that is the parser object itself,
+so you can access its methods, specially the
+
+ $_[0]->YYData
+
+data area.
+
+It is its duty to return the next token and value to the parser.
+They C<must> be returned as a list of two variables, the first one
+is the token known by the parser (symbolic or literal), the second
+one beeing anything you want (usualy the content of the token, or the
+literal value) from a simple scalar value to any complex reference,
+as the parsing driver never use it but to call semantic actions:
+
+ ( 'NUMBER', $num )
+or
+ ( '>=', '>=' )
+or
+ ( 'ARRAY', [ @values ] )
+
+When the lexer reach the end of input, it must return the C<''>
+empty token with an undef value:
+
+ ( '', undef )
+
+Note that your lexer should I<never> return C<'error'> as token
+value: for the driver, this is the error token used for error
+recovery and would lead to odd reactions.
+
+Now that you have your lexer written, maybe you will need to output
+meaningful error messages, instead of the default which is to print
+'Parse error.' on STDERR.
+
+So you will need an Error reporting sub.
+
+item C<Error reporting routine>
+
+If you want one, write it knowing that it is passed as parameter
+the parser object. So you can share information whith the lexer
+routine quite easily.
+
+You can also use the C<$_[0]-E<gt>YYErrok> method in it, which will
+resume parsing as if no error occured. Of course, since the invalid
+token is still invalid, you're supposed to fix the problem by
+yourself.
+
+The method C<$_[0]-E<gt>YYLexer> may help you, as it returns a reference
+to the lexer routine, and can be called as
+
+ ($tok,$val)=&{$_[0]->Lexer}
+
+to get the next token and semantic value from the input stream. To
+make them current for the parser, use:
+
+ ($_[0]->YYCurtok, $_[0]->YYCurval) = ($tok, $val)
+
+and know what you're doing...
+
+=item C<Parsing>
+
+Now you've got everything to do the parsing.
+
+First, use the parser module:
+
+ use Calc;
+
+Then create the parser object:
+
+ $parser=new Calc;
+
+Now, call the YYParse method, telling it where to find the lexer
+and error report subs:
+
+ $result=$parser->YYParse(yylex => \&Lexer,
+ yyerror => \&ErrorReport);
+
+(assuming Lexer and ErrorReport subs have been written in your current
+package)
+
+The order in which parameters appear is unimportant.
+
+Et voila.
+
+The YYParse method will do the parse, then return the last semantic
+value returned, or undef if error recovery cannot recover.
+
+If you need to be sure the parse has been successful (in case your
+last returned semantic value I<is> undef) make a call to:
+
+ $parser->YYNberr()
+
+which returns the total number of time the error reporting sub has been called.
+
+=item C<Error Recovery>
+
+in Parse::Yapp is implemented the same way it is in yacc.
+
+=item C<Debugging Parser>
+
+To debug your parser, you can call the YYParse method with a debug parameter:
+
+ $parser->YYParse( ... , yydebug => value, ... )
+
+where value is a bitfield, each bit representing a specific debug output:
+
+ Bit Value Outputs
+ 0x01 Token reading (useful for Lexer debugging)
+ 0x02 States information
+ 0x04 Driver actions (shifts, reduces, accept...)
+ 0x08 Parse Stack dump
+ 0x10 Error Recovery tracing
+
+To have a full debugging ouput, use
+
+ debug => 0x1F
+
+Debugging output is sent to STDERR, and be aware that it can produce
+C<huge> outputs.
+
+=item C<Standalone Parsers>
+
+By default, the parser modules generated will need the Parse::Yapp
+module installed on the system to run. They use the Parse::Yapp::Driver
+which can be safely shared between parsers in the same script.
+
+In the case you'd prefer to have a standalone module generated, use
+the C<-s> switch with yapp: this will automagically copy the driver
+code into your module so you can use/distribute it without the need
+of the Parse::Yapp module, making it really a C<Standalone Parser>.
+
+If you do so, please remember to include Parse::Yapp's copyright notice
+in your main module copyright, so others can know about Parse::Yapp module.
+
+=item C<Source file line numbers>
+
+by default will be included in the generated parser module, which will help
+to find the guilty line in your source file in case of a syntax error.
+You can disable this feature by compiling your grammar with yapp using
+the C<-n> switch.
+
+=back
+
+=head1 BUGS AND SUGGESTIONS
+
+If you find bugs, think of anything that could improve Parse::Yapp
+or have any questions related to it, feel free to contact the author.
+
+=head1 AUTHOR
+
+Francois Desarmenien <francois@fdesar.net>
+
+=head1 SEE ALSO
+
+yapp(1) perl(1) yacc(1) bison(1).
+
+=head1 COPYRIGHT
+
+The Parse::Yapp module and its related modules and shell scripts are copyright
+(c) 1998-2001 Francois Desarmenien, France. All rights reserved.
+
+You may use and distribute them under the terms of either
+the GNU General Public License or the Artistic License,
+as specified in the Perl README file.
+
+If you use the "standalone parser" option so people don't need to install
+Parse::Yapp on their systems in order to run you software, this copyright
+noticed should be included in your software copyright too, and the copyright
+notice in the embedded driver should be left untouched.
+
+=cut
471 Pugs/blib6/pugs/perl5/lib/Parse/Yapp/Driver.pm
@@ -0,0 +1,471 @@
+#
+# Module Parse::Yapp::Driver
+#
+# This module is part of the Parse::Yapp package available on your
+# nearest CPAN
+#
+# Any use of this module in a standalone parser make the included
+# text under the same copyright as the Parse::Yapp module itself.
+#
+# This notice should remain unchanged.
+#
+# (c) Copyright 1998-2001 Francois Desarmenien, all rights reserved.
+# (see the pod text in Parse::Yapp module for use and distribution rights)
+#
+
+package Parse::Yapp::Driver;
+
+require 5.004;
+
+use strict;
+
+use vars qw ( $VERSION $COMPATIBLE $FILENAME );
+
+$VERSION = '1.05';
+$COMPATIBLE = '0.07';
+$FILENAME=__FILE__;
+
+use Carp;
+
+#Known parameters, all starting with YY (leading YY will be discarded)
+my(%params)=(YYLEX => 'CODE', 'YYERROR' => 'CODE', YYVERSION => '',
+ YYRULES => 'ARRAY', YYSTATES => 'ARRAY', YYDEBUG => '');
+#Mandatory parameters
+my(@params)=('LEX','RULES','STATES');
+
+sub new {
+ my($class)=shift;
+ my($errst,$nberr,$token,$value,$check,$dotpos);
+ my($self)={ ERROR => \&_Error,
+ ERRST => \$errst,
+ NBERR => \$nberr,
+ TOKEN => \$token,
+ VALUE => \$value,
+ DOTPOS => \$dotpos,
+ STACK => [],
+ DEBUG => 0,
+ CHECK => \$check };
+
+ _CheckParams( [], \%params, \@_, $self );
+
+ exists($$self{VERSION})
+ and $$self{VERSION} < $COMPATIBLE
+ and croak "Yapp driver version $VERSION ".
+ "incompatible with version $$self{VERSION}:\n".
+ "Please recompile parser module.";
+
+ ref($class)
+ and $class=ref($class);
+
+ bless($self,$class);
+}
+
+sub YYParse {
+ my($self)=shift;
+ my($retval);
+
+ _CheckParams( \@params, \%params, \@_, $self );
+
+ if($$self{DEBUG}) {
+ _DBLoad();
+ $retval = eval '$self->_DBParse()';#Do not create stab entry on compile
+ $@ and die $@;
+ }
+ else {
+ $retval = $self->_Parse();
+ }
+ $retval
+}
+
+sub YYData {
+ my($self)=shift;
+
+ exists($$self{USER})
+ or $$self{USER}={};
+
+ $$self{USER};
+
+}
+
+sub YYErrok {
+ my($self)=shift;
+
+ ${$$self{ERRST}}=0;
+ undef;
+}
+
+sub YYNberr {
+ my($self)=shift;
+
+ ${$$self{NBERR}};
+}
+
+sub YYRecovering {
+ my($self)=shift;
+
+ ${$$self{ERRST}} != 0;
+}
+
+sub YYAbort {
+ my($self)=shift;
+
+ ${$$self{CHECK}}='ABORT';
+ undef;
+}
+
+sub YYAccept {
+ my($self)=shift;
+
+ ${$$self{CHECK}}='ACCEPT';
+ undef;
+}
+
+sub YYError {
+ my($self)=shift;
+
+ ${$$self{CHECK}}='ERROR';
+ undef;
+}
+
+sub YYSemval {
+ my($self)=shift;
+ my($index)= $_[0] - ${$$self{DOTPOS}} - 1;
+
+ $index < 0
+ and -$index <= @{$$self{STACK}}
+ and return $$self{STACK}[$index][1];
+
+ undef; #Invalid index
+}
+
+sub YYCurtok {
+ my($self)=shift;
+
+ @_
+ and ${$$self{TOKEN}}=$_[0];
+ ${$$self{TOKEN}};
+}
+
+sub YYCurval {
+ my($self)=shift;
+
+ @_
+ and ${$$self{VALUE}}=$_[0];
+ ${$$self{VALUE}};
+}
+
+sub YYExpect {
+ my($self)=shift;
+
+ keys %{$self->{STATES}[$self->{STACK}[-1][0]]{ACTIONS}}
+}
+
+sub YYLexer {
+ my($self)=shift;
+
+ $$self{LEX};
+}
+
+
+#################
+# Private stuff #
+#################
+
+
+sub _CheckParams {
+ my($mandatory,$checklist,$inarray,$outhash)=@_;
+ my($prm,$value);
+ my($prmlst)={};
+
+ while(($prm,$value)=splice(@$inarray,0,2)) {
+ $prm=uc($prm);
+ exists($$checklist{$prm})
+ or croak("Unknow parameter '$prm'");
+ ref($value) eq $$checklist{$prm}
+ or croak("Invalid value for parameter '$prm'");
+ $prm=unpack('@2A*',$prm);
+ $$outhash{$prm}=$value;
+ }
+ for (@$mandatory) {
+ exists($$outhash{$_})
+ or croak("Missing mandatory parameter '".lc($_)."'");
+ }
+}
+
+sub _Error {
+ print "Parse error.\n";
+}
+
+sub _DBLoad {
+ {
+ no strict 'refs';
+
+ exists(${__PACKAGE__.'::'}{_DBParse})#Already loaded ?
+ and return;
+ }
+ my($fname)=__FILE__;
+ my(@drv);
+ open(DRV,"<$fname") or die "Report this as a BUG: Cannot open $fname";
+ while(<DRV>) {
+ /^\s*sub\s+_Parse\s*{\s*$/ .. /^\s*}\s*#\s*_Parse\s*$/
+ and do {
+ s/^#DBG>//;
+ push(@drv,$_);
+ }
+ }
+ close(DRV);
+
+ $drv[0]=~s/_P/_DBP/;
+ eval join('',@drv);
+}
+
+#Note that for loading debugging version of the driver,
+#this file will be parsed from 'sub _Parse' up to '}#_Parse' inclusive.
+#So, DO NOT remove comment at end of sub !!!
+sub _Parse {
+ my($self)=shift;
+
+ my($rules,$states,$lex,$error)
+ = @$self{ 'RULES', 'STATES', 'LEX', 'ERROR' };
+ my($errstatus,$nberror,$token,$value,$stack,$check,$dotpos)
+ = @$self{ 'ERRST', 'NBERR', 'TOKEN', 'VALUE', 'STACK', 'CHECK', 'DOTPOS' };
+
+#DBG> my($debug)=$$self{DEBUG};
+#DBG> my($dbgerror)=0;
+
+#DBG> my($ShowCurToken) = sub {
+#DBG> my($tok)='>';
+#DBG> for (split('',$$token)) {
+#DBG> $tok.= (ord($_) < 32 or ord($_) > 126)
+#DBG> ? sprintf('<%02X>',ord($_))
+#DBG> : $_;
+#DBG> }
+#DBG> $tok.='<';
+#DBG> };
+
+ $$errstatus=0;
+ $$nberror=0;
+ ($$token,$$value)=(undef,undef);
+ @$stack=( [ 0, undef ] );
+ $$check='';
+
+ while(1) {
+ my($actions,$act,$stateno);
+
+ $stateno=$$stack[-1][0];
+ $actions=$$states[$stateno];
+
+#DBG> print STDERR ('-' x 40),"\n";
+#DBG> $debug & 0x2
+#DBG> and print STDERR "In state $stateno:\n";
+#DBG> $debug & 0x08
+#DBG> and print STDERR "Stack:[".
+#DBG> join(',',map { $$_[0] } @$stack).
+#DBG> "]\n";
+
+
+ if (exists($$actions{ACTIONS})) {
+
+ defined($$token)
+ or do {
+ ($$token,$$value)=&$lex($self);
+#DBG> $debug & 0x01
+#DBG> and print STDERR "Need token. Got ".&$ShowCurToken."\n";
+ };
+
+ $act= exists($$actions{ACTIONS}{$$token})
+ ? $$actions{ACTIONS}{$$token}
+ : exists($$actions{DEFAULT})
+ ? $$actions{DEFAULT}
+ : undef;
+ }
+ else {
+ $act=$$actions{DEFAULT};
+#DBG> $debug & 0x01
+#DBG> and print STDERR "Don't need token.\n";
+ }
+
+ defined($act)
+ and do {
+
+ $act > 0
+ and do { #shift
+
+#DBG> $debug & 0x04
+#DBG> and print STDERR "Shift and go to state $act.\n";
+
+ $$errstatus
+ and do {
+ --$$errstatus;
+
+#DBG> $debug & 0x10
+#DBG> and $dbgerror
+#DBG> and $$errstatus == 0
+#DBG> and do {
+#DBG> print STDERR "**End of Error recovery.\n";
+#DBG> $dbgerror=0;
+#DBG> };
+ };
+
+
+ push(@$stack,[ $act, $$value ]);
+
+ $$token ne '' #Don't eat the eof
+ and $$token=$$value=undef;
+ next;
+ };
+
+ #reduce
+ my($lhs,$len,$code,@sempar,$semval);
+ ($lhs,$len,$code)=@{$$rules[-$act]};
+
+#DBG> $debug & 0x04
+#DBG> and $act
+#DBG> and print STDERR "Reduce using rule ".-$act." ($lhs,$len): ";
+
+ $act
+ or $self->YYAccept();
+
+ $$dotpos=$len;
+
+ unpack('A1',$lhs) eq '@' #In line rule
+ and do {
+ $lhs =~ /^\@[0-9]+\-([0-9]+)$/
+ or die "In line rule name '$lhs' ill formed: ".
+ "report it as a BUG.\n";
+ $$dotpos = $1;
+ };
+
+ @sempar = $$dotpos
+ ? map { $$_[1] } @$stack[ -$$dotpos .. -1 ]
+ : ();
+
+ $semval = $code ? &$code( $self, @sempar )
+ : @sempar ? $sempar[0] : undef;
+
+ splice(@$stack,-$len,$len);
+
+ $$check eq 'ACCEPT'
+ and do {
+
+#DBG> $debug & 0x04
+#DBG> and print STDERR "Accept.\n";
+
+ return($semval);
+ };
+
+ $$check eq 'ABORT'
+ and do {
+
+#DBG> $debug & 0x04
+#DBG> and print STDERR "Abort.\n";
+
+ return(undef);
+
+ };
+
+#DBG> $debug & 0x04
+#DBG> and print STDERR "Back to state $$stack[-1][0], then ";
+
+ $$check eq 'ERROR'
+ or do {
+#DBG> $debug & 0x04
+#DBG> and print STDERR
+#DBG> "go to state $$states[$$stack[-1][0]]{GOTOS}{$lhs}.\n";
+
+#DBG> $debug & 0x10
+#DBG> and $dbgerror
+#DBG> and $$errstatus == 0
+#DBG> and do {
+#DBG> print STDERR "**End of Error recovery.\n";
+#DBG> $dbgerror=0;
+#DBG> };
+
+ push(@$stack,
+ [ $$states[$$stack[-1][0]]{GOTOS}{$lhs}, $semval ]);
+ $$check='';
+ next;
+ };
+
+#DBG> $debug & 0x04
+#DBG> and print STDERR "Forced Error recovery.\n";
+
+ $$check='';
+
+ };
+
+ #Error
+ $$errstatus
+ or do {
+
+ $$errstatus = 1;
+ &$error($self);
+ $$errstatus # if 0, then YYErrok has been called
+ or next; # so continue parsing
+
+#DBG> $debug & 0x10
+#DBG> and do {
+#DBG> print STDERR "**Entering Error recovery.\n";
+#DBG> ++$dbgerror;
+#DBG> };
+
+ ++$$nberror;
+
+ };
+
+ $$errstatus == 3 #The next token is not valid: discard it
+ and do {
+ $$token eq '' # End of input: no hope
+ and do {
+#DBG> $debug & 0x10
+#DBG> and print STDERR "**At eof: aborting.\n";
+ return(undef);
+ };
+
+#DBG> $debug & 0x10
+#DBG> and print STDERR "**Dicard invalid token ".&$ShowCurToken.".\n";
+
+ $$token=$$value=undef;
+ };
+
+ $$errstatus=3;
+
+ while( @$stack
+ and ( not exists($$states[$$stack[-1][0]]{ACTIONS})
+ or not exists($$states[$$stack[-1][0]]{ACTIONS}{error})
+ or $$states[$$stack[-1][0]]{ACTIONS}{error} <= 0)) {
+
+#DBG> $debug & 0x10
+#DBG> and print STDERR "**Pop state $$stack[-1][0].\n";
+
+ pop(@$stack);
+ }
+
+ @$stack
+ or do {
+
+#DBG> $debug & 0x10
+#DBG> and print STDERR "**No state left on stack: aborting.\n";
+
+ return(undef);
+ };
+
+ #shift the error token
+
+#DBG> $debug & 0x10
+#DBG> and print STDERR "**Shift \$error token and go to state ".
+#DBG> $$states[$$stack[-1][0]]{ACTIONS}{error}.
+#DBG> ".\n";
+
+ push(@$stack, [ $$states[$$stack[-1][0]]{ACTIONS}{error}, undef ]);
+
+ }
+
+ #never reached
+ croak("Error in driver logic. Please, report it as a BUG");
+
+}#_Parse
+#DO NOT remove comment
+
+1;
+
381 Pugs/blib6/pugs/perl5/lib/Parse/Yapp/Grammar.pm
@@ -0,0 +1,381 @@
+#
+# Module Parse::Yapp::Grammar
+#
+# (c) Copyright 1998-2001 Francois Desarmenien, all rights reserved.
+# (see the pod text in Parse::Yapp module for use and distribution rights)
+#
+package Parse::Yapp::Grammar;
+@ISA=qw( Parse::Yapp::Options );
+
+require 5.004;
+
+use Carp;
+use strict;
+use Parse::Yapp::Options;
+use Parse::Yapp::Parse;
+
+###############
+# Constructor #
+###############
+sub new {
+ my($class)=shift;
+ my($values);
+
+ my($self)=$class->SUPER::new(@_);
+
+ my($parser)=new Parse::Yapp::Parse;
+
+ defined($self->Option('input'))
+ or croak "No input grammar";
+
+ $values = $parser->Parse($self->Option('input'));
+
+ undef($parser);
+
+ $$self{GRAMMAR}=_ReduceGrammar($values);
+
+ ref($class)
+ and $class=ref($class);
+
+ bless($self, $class);
+}
+
+###########
+# Methods #
+###########
+##########################
+# Method To View Grammar #
+##########################
+sub ShowRules {
+ my($self)=shift;
+ my($rules)=$$self{GRAMMAR}{RULES};
+ my($ruleno)=-1;
+ my($text);
+
+ for (@$rules) {
+ my($lhs,$rhs)=@$_;
+
+ $text.=++$ruleno.":\t".$lhs." -> ";
+ if(@$rhs) {
+ $text.=join(' ',map { $_ eq chr(0) ? '$end' : $_ } @$rhs);
+ }
+ else {
+ $text.="/* empty */";
+ }
+ $text.="\n";
+ }
+ $text;
+}
+
+###########################
+# Method To View Warnings #
+###########################
+sub Warnings {
+ my($self)=shift;
+ my($text);
+ my($grammar)=$$self{GRAMMAR};
+
+ exists($$grammar{UUTERM})
+ and do {
+ $text="Unused terminals:\n\n";
+ for (@{$$grammar{UUTERM}}) {
+ $text.="\t$$_[0], declared line $$_[1]\n";
+ }
+ $text.="\n";
+ };
+ exists($$grammar{UUNTERM})
+ and do {
+ $text.="Useless non-terminals:\n\n";
+ for (@{$$grammar{UUNTERM}}) {
+ $text.="\t$$_[0], declared line $$_[1]\n";
+ }
+ $text.="\n";
+ };
+ exists($$grammar{UURULES})
+ and do {
+ $text.="Useless rules:\n\n";
+ for (@{$$grammar{UURULES}}) {
+ $text.="\t$$_[0] -> ".join(' ',@{$$_[1]})."\n";
+ }
+ $text.="\n";
+ };
+ $text;
+}
+
+######################################
+# Method to get summary about parser #
+######################################
+sub Summary {
+ my($self)=shift;
+ my($text);
+
+ $text ="Number of rules : ".
+ scalar(@{$$self{GRAMMAR}{RULES}})."\n";
+ $text.="Number of terminals : ".
+ scalar(keys(%{$$self{GRAMMAR}{TERM}}))."\n";
+ $text.="Number of non-terminals : ".
+ scalar(keys(%{$$self{GRAMMAR}{NTERM}}))."\n";
+ $text;
+}
+
+###############################
+# Method to Ouput rules table #
+###############################
+sub RulesTable {
+ my($self)=shift;
+ my($inputfile)=$self->Option('inputfile');
+ my($linenums)=$self->Option('linenumbers');
+ my($rules)=$$self{GRAMMAR}{RULES};
+ my($ruleno);
+ my($text);
+
+ defined($inputfile)
+ or $inputfile = 'unkown';
+
+ $text="[\n\t";
+
+ $text.=join(",\n\t",
+ map {
+ my($lhs,$rhs,$code)=@$_[0,1,3];
+ my($len)=scalar(@$rhs);
+ my($text);
+
+ $text.="[#Rule ".$ruleno++."\n\t\t '$lhs', $len,";
+ if($code) {
+ $text.= "\nsub".
+ ( $linenums
+ ? qq(\n#line $$code[1] "$inputfile"\n)
+ : " ").
+ "{$$code[0]}";
+ }
+ else {
+ $text.=' undef';
+ }
+ $text.="\n\t]";
+
+ $text;
+ } @$rules);
+
+ $text.="\n]";
+
+ $text;
+}
+
+################################
+# Methods to get HEAD and TAIL #
+################################
+sub Head {
+ my($self)=shift;
+ my($inputfile)=$self->Option('inputfile');
+ my($linenums)=$self->Option('linenumbers');
+ my($text);
+
+ $$self{GRAMMAR}{HEAD}[0]
+ or return '';
+
+ defined($inputfile)
+ or $inputfile = 'unkown';
+
+ for (@{$$self{GRAMMAR}{HEAD}}) {
+ $linenums
+ and $text.=qq(#line $$_[1] "$inputfile"\n);
+ $text.=$$_[0];
+ }
+ $text
+}
+
+sub Tail {
+ my($self)=shift;
+ my($inputfile)=$self->Option('inputfile');
+ my($linenums)=$self->Option('linenumbers');
+ my($text);
+
+ $$self{GRAMMAR}{TAIL}[0]
+ or return '';
+
+ defined($inputfile)
+ or $inputfile = 'unkown';
+
+ $linenums
+ and $text=qq(#line $$self{GRAMMAR}{TAIL}[1] "$inputfile"\n);
+ $text.=$$self{GRAMMAR}{TAIL}[0];
+
+ $text
+}
+
+
+#################
+# Private Stuff #
+#################
+
+sub _UsefulRules {
+ my($rules,$nterm) = @_;
+ my($ufrules,$ufnterm);
+ my($done);
+
+ $ufrules=pack('b'.@$rules);
+ $ufnterm={};
+
+ vec($ufrules,0,1)=1; #start rules IS always useful
+
+ RULE:
+ for (1..$#$rules) { # Ignore start rule
+ for my $sym (@{$$rules[$_][1]}) {
+ exists($$nterm{$sym})
+ and next RULE;
+ }
+ vec($ufrules,$_,1)=1;
+ ++$$ufnterm{$$rules[$_][0]};
+ }
+
+ do {
+ $done=1;
+
+ RULE:
+ for (grep { vec($ufrules,$_,1) == 0 } 1..$#$rules) {
+ for my $sym (@{$$rules[$_][1]}) {
+ exists($$nterm{$sym})
+ and not exists($$ufnterm{$sym})
+ and next RULE;
+ }
+ vec($ufrules,$_,1)=1;
+ exists($$ufnterm{$$rules[$_][0]})
+ or do {
+ $done=0;
+ ++$$ufnterm{$$rules[$_][0]};
+ };
+ }
+
+ }until($done);
+
+ ($ufrules,$ufnterm)
+
+}#_UsefulRules
+
+sub _Reachable {
+ my($rules,$nterm,$term,$ufrules,$ufnterm)=@_;
+ my($reachable);
+ my(@fifo)=( 0 );
+
+ $reachable={ '$start' => 1 }; #$start is always reachable
+
+ while(@fifo) {
+ my($ruleno)=shift(@fifo);
+
+ for my $sym (@{$$rules[$ruleno][1]}) {
+
+ exists($$term{$sym})
+ and do {
+ ++$$reachable{$sym};
+ next;
+ };
+
+ ( not exists($$ufnterm{$sym})
+ or exists($$reachable{$sym}) )
+ and next;
+
+ ++$$reachable{$sym};
+ push(@fifo, grep { vec($ufrules,$_,1) } @{$$nterm{$sym}});
+ }
+ }
+
+ $reachable
+
+}#_Reachable
+
+sub _SetNullable {
+ my($rules,$term,$nullable) = @_;
+ my(@nrules);
+ my($done);
+
+ RULE:
+ for (@$rules) {
+ my($lhs,$rhs)=@$_;
+
+ exists($$nullable{$lhs})
+ and next;
+
+ for (@$rhs) {
+ exists($$term{$_})
+ and next RULE;
+ }
+ push(@nrules,[$lhs,$rhs]);
+ }
+
+ do {
+ $done=1;
+
+ RULE:
+ for (@nrules) {
+ my($lhs,$rhs)=@$_;
+
+ exists($$nullable{$lhs})
+ and next;
+
+ for (@$rhs) {
+ exists($$nullable{$_})
+ or next RULE;
+ }
+ $done=0;
+ ++$$nullable{$lhs};
+ }
+
+ }until($done);
+}
+
+sub _ReduceGrammar {
+ my($values)=@_;
+ my($ufrules,$ufnterm,$reachable);
+ my($grammar)={ HEAD => $values->{HEAD},
+ TAIL => $values->{TAIL},
+ EXPECT => $values->{EXPECT} };
+ my($rules,$nterm,$term) = @$values {'RULES', 'NTERM', 'TERM'};
+
+ ($ufrules,$ufnterm) = _UsefulRules($rules,$nterm);
+
+ exists($$ufnterm{$values->{START}})
+ or die "*Fatal* Start symbol $values->{START} derives nothing, at eof\n";
+
+ $reachable = _Reachable($rules,$nterm,$term,$ufrules,$ufnterm);
+
+ $$grammar{TERM}{chr(0)}=undef;
+ for my $sym (keys %$term) {
+ ( exists($$reachable{$sym})
+ or exists($values->{PREC}{$sym}) )
+ and do {
+ $$grammar{TERM}{$sym}
+ = defined($$term{$sym}[0]) ? $$term{$sym} : undef;
+ next;
+ };
+ push(@{$$grammar{UUTERM}},[ $sym, $values->{SYMS}{$sym} ]);
+ }
+
+ $$grammar{NTERM}{'$start'}=[];
+ for my $sym (keys %$nterm) {
+ exists($$reachable{$sym})
+ and do {
+ exists($values->{NULL}{$sym})
+ and ++$$grammar{NULLABLE}{$sym};
+ $$grammar{NTERM}{$sym}=[];
+ next;
+ };
+ push(@{$$grammar{UUNTERM}},[ $sym, $values->{SYMS}{$sym} ]);
+ }
+
+ for my $ruleno (0..$#$rules) {
+ vec($ufrules,$ruleno,1)
+ and exists($$grammar{NTERM}{$$rules[$ruleno][0]})
+ and do {
+ push(@{$$grammar{RULES}},$$rules[$ruleno]);
+ push(@{$$grammar{NTERM}{$$rules[$ruleno][0]}},$#{$$grammar{RULES}});
+ next;
+ };
+ push(@{$$grammar{UURULES}},[ @{$$rules[$ruleno]}[0,1] ]);
+ }
+
+ _SetNullable(@$grammar{'RULES', 'TERM', 'NULLABLE'});
+
+ $grammar;
+}#_ReduceGrammar
+
+1;
939 Pugs/blib6/pugs/perl5/lib/Parse/Yapp/Lalr.pm
@@ -0,0 +1,939 @@
+#
+# Module Parse::Yapp::Lalr
+#
+# (c) Copyright 1998-2001 Francois Desarmenien, all rights reserved.
+# (see the pod text in Parse::Yapp module for use and distribution rights)
+#
+package Parse::Yapp::Lalr;
+@ISA=qw( Parse::Yapp::Grammar );
+
+require 5.004;
+
+use Parse::Yapp::Grammar;
+
+=for nobody
+
+Parse::Yapp::Compile Object Structure:
+--------------------------------------
+{
+ GRAMMAR => Parse::Yapp::Grammar,
+ STATES => [ { CORE => [ items... ],
+ ACTIONS => { term => action }
+ GOTOS => { nterm => stateno }
+ }... ]
+ CONFLICTS=>{ SOLVED => { stateno => [ ruleno, token, solved ] },
+ FORCED => { TOTAL => [ nbsr, nbrr ],
+ DETAIL => { stateno => { TOTAL => [ nbsr, nbrr ] }
+ LIST => [ ruleno, token ]
+ }
+ }
+ }
+}
+
+'items' are of form: [ ruleno, dotpos ]
+'term' in ACTIONS is '' means default action
+'action' may be:
+ undef: explicit error (nonassociativity)
+ 0 : accept
+ >0 : shift and go to state 'action'
+ <0 : reduce using rule -'action'
+'solved' may have values of:
+ 'shift' if solved as Shift
+ 'reduce' if solved as Reduce
+ 'error' if solved by discarding both Shift and Reduce (nonassoc)
+
+SOLVED is a set of states containing Solved conflicts
+FORCED are forced conflict resolutions
+
+nbsr and nbrr are number of shift/reduce and reduce/reduce conflicts
+
+TOTAL is the total number of SR/RR conflicts for the parser
+
+DETAIL is the detail of conflicts for each state
+TOTAL is the total number of SR/RR conflicts for a state
+LIST is the list of discarded reductions (for display purpose only)
+
+
+=cut
+
+use strict;
+
+use Carp;
+
+###############
+# Constructor #
+###############
+sub new {
+ my($class)=shift;
+
+ ref($class)
+ and $class=ref($class);
+
+ my($self)=$class->SUPER::new(@_);
+ $self->_Compile();
+ bless($self,$class);
+}
+###########
+# Methods #
+###########
+
+###########################
+# Method To View Warnings #
+###########################
+sub Warnings {
+ my($self)=shift;
+ my($text);
+ my($nbsr,$nbrr)=@{$$self{CONFLICTS}{FORCED}{TOTAL}};
+
+ $text=$self->SUPER::Warnings();
+
+ $nbsr != $$self{GRAMMAR}{EXPECT}
+ and $text.="$nbsr shift/reduce conflict".($nbsr > 1 ? "s" : "");
+
+ $nbrr
+ and do {
+ $nbsr
+ and $text.=" and ";
+ $text.="$nbrr reduce/reduce conflict".($nbrr > 1 ? "s" : "");
+ };
+
+ ( $nbsr != $$self{GRAMMAR}{EXPECT}
+ or $nbrr)
+ and $text.="\n";
+
+ $text;
+}
+#############################
+# Method To View DFA States #
+#############################
+sub ShowDfa {
+ my($self)=shift;
+ my($text);
+ my($grammar,$states)=($$self{GRAMMAR}, $$self{STATES});
+
+ for my $stateno (0..$#$states) {
+ my(@shifts,@reduces,@errors,$default);
+
+ $text.="State $stateno:\n\n";
+
+ #Dump Kernel Items
+ for (sort { $$a[0] <=> $$b[0]
+ or $$a[1] <=> $$b[1] } @{$$states[$stateno]{'CORE'}}) {
+ my($ruleno,$pos)=@$_;
+ my($lhs,$rhs)=@{$$grammar{RULES}[$ruleno]}[0,1];
+ my(@rhscopy)=@$rhs;
+
+ $ruleno
+ or $rhscopy[-1] = '$end';
+
+ splice(@rhscopy,$pos,0,'.');
+ $text.= "\t$lhs -> ".join(' ',@rhscopy)."\t(Rule $ruleno)\n";
+ }
+
+ #Prepare Actions
+ for (keys(%{$$states[$stateno]{ACTIONS}})) {
+ my($term,$action)=($_,$$states[$stateno]{ACTIONS}{$_});
+
+ $term eq chr(0)
+ and $term = '$end';
+
+ not defined($action)
+ and do {
+ push(@errors,$term);
+ next;
+ };
+
+ $action > 0
+ and do {
+ push(@shifts,[ $term, $action ]);
+ next;
+ };
+
+ $action = -$action;
+
+ $term
+ or do {
+ $default= [ '$default', $action ];
+ next;
+ };
+
+ push(@reduces,[ $term, $action ]);
+ }
+
+ #Dump shifts
+ @shifts
+ and do {
+ $text.="\n";
+ for (sort { $$a[0] cmp $$b[0] } @shifts) {
+ my($term,$shift)=@$_;
+
+ $text.="\t$term\tshift, and go to state $shift\n";
+ }
+ };
+
+ #Dump errors
+ @errors
+ and do {
+ $text.="\n";
+ for my $term (sort { $a cmp $b } @errors) {
+ $text.="\t$term\terror (nonassociative)\n";
+ }
+ };
+
+ #Prepare reduces
+ exists($$self{CONFLICTS}{FORCED}{DETAIL}{$stateno})
+ and push(@reduces,@{$$self{CONFLICTS}{FORCED}{DETAIL}{$stateno}{LIST}});
+
+ @reduces=sort { $$a[0] cmp $$b[0] or $$a[1] <=> $$b[1] } @reduces;
+
+ defined($default)
+ and push(@reduces,$default);
+
+ #Dump reduces
+ @reduces
+ and do {
+ $text.="\n";
+ for (@reduces) {
+ my($term,$ruleno)=@$_;
+ my($discard);
+
+ $ruleno < 0
+ and do {
+ ++$discard;
+ $ruleno = -$ruleno;
+ };
+
+ $text.= "\t$term\t".($discard ? "[" : "");
+ if($ruleno) {
+ $text.= "reduce using rule $ruleno ".
+ "($$grammar{RULES}[$ruleno][0])";
+ }
+ else {
+ $text.='accept';
+ }
+ $text.=($discard ? "]" : "")."\n";
+ }
+ };
+
+ #Dump gotos
+ exists($$states[$stateno]{GOTOS})
+ and do {
+ $text.= "\n";
+ for (keys(%{$$states[$stateno]{GOTOS}})) {
+ $text.= "\t$_\tgo to state $$states[$stateno]{GOTOS}{$_}\n";
+ }
+ };
+
+ $text.="\n";
+ }
+ $text;
+}
+
+######################################
+# Method to get summary about parser #
+######################################
+sub Summary {
+ my($self)=shift;
+ my($text);
+
+ $text=$self->SUPER::Summary();
+ $text.="Number of states : ".
+ scalar(@{$$self{STATES}})."\n";
+ $text;
+}
+
+#######################################
+# Method To Get Infos about conflicts #
+#######################################
+sub Conflicts {
+ my($self)=shift;
+ my($states)=$$self{STATES};
+ my($conflicts)=$$self{CONFLICTS};
+ my($text);
+
+ for my $stateno ( sort { $a <=> $b } keys(%{$$conflicts{SOLVED}})) {
+
+ for (@{$$conflicts{SOLVED}{$stateno}}) {
+ my($ruleno,$token,$how)=@$_;
+
+ $token eq chr(0)
+ and $token = '$end';
+
+ $text.="Conflict in state $stateno between rule ".
+ "$ruleno and token $token resolved as $how.\n";
+ }
+ };
+
+ for my $stateno ( sort { $a <=> $b } keys(%{$$conflicts{FORCED}{DETAIL}})) {
+ my($nbsr,$nbrr)=@{$$conflicts{FORCED}{DETAIL}{$stateno}{TOTAL}};
+
+ $text.="State $stateno contains ";
+
+ $nbsr
+ and $text.="$nbsr shift/reduce conflict".
+ ($nbsr > 1 ? "s" : "");
+
+ $nbrr
+ and do {
+ $nbsr
+ and $text.=" and ";
+
+ $text.="$nbrr reduce/reduce conflict".
+ ($nbrr > 1 ? "s" : "");
+ };
+ $text.="\n";
+ };
+
+ $text;
+}
+
+#################################
+# Method to dump parsing tables #
+#################################
+sub DfaTable {
+ my($self)=shift;
+ my($states)=$$self{STATES};
+ my($stateno);
+ my($text);
+
+ $text="[\n\t{";
+
+ $text.=join("\n\t},\n\t{",
+ map {
+ my($state)=$_;
+ my($text);
+
+ $text="#State ".$stateno++."\n\t\t";
+
+ ( not exists($$state{ACTIONS}{''})
+ or keys(%{$$state{ACTIONS}}) > 1)
+ and do {
+
+ $text.="ACTIONS => {\n\t\t\t";
+
+ $text.=join(",\n\t\t\t",
+ map {
+ my($term,$action)=($_,$$state{ACTIONS}{$_});
+ my($text);
+
+ if(substr($term,0,1) eq "'") {
+ $term=~s/([\@\$\"])/\\$1/g;
+ $term=~s/^'|'$/"/g;
+ }
+ else {
+ $term= $term eq chr(0)
+ ? "''"
+ : "'$term'";
+ }
+
+ if(defined($action)) {
+ $action=int($action);
+ }
+ else {
+ $action='undef';
+ }
+
+ "$term => $action";
+
+ } grep { $_ } keys(%{$$state{ACTIONS}}));
+
+ $text.="\n\t\t}";
+ };
+
+ exists($$state{ACTIONS}{''})
+ and do {
+ keys(%{$$state{ACTIONS}}) > 1
+ and $text.=",\n\t\t";
+
+ $text.="DEFAULT => $$state{ACTIONS}{''}";
+ };
+
+ exists($$state{GOTOS})
+ and do {
+ $text.=",\n\t\tGOTOS => {\n\t\t\t";
+ $text.=join(",\n\t\t\t",
+ map {
+ my($nterm,$stateno)=($_,$$state{GOTOS}{$_});
+ my($text);
+
+ "'$nterm' => $stateno";
+
+ } keys(%{$$state{GOTOS}}));
+ $text.="\n\t\t}";
+ };
+
+ $text;
+
+ }@$states);
+
+ $text.="\n\t}\n]";
+
+ $text;
+
+}
+
+
+####################################
+# Method to build Dfa from Grammar #
+####################################
+sub _Compile {
+ my($self)=shift;
+ my($grammar,$states);
+
+ $grammar=$self->{GRAMMAR};
+
+ $states = _LR0($grammar);
+
+ $self->{CONFLICTS} = _LALR($grammar,$states);
+
+ $self->{STATES}=$states;
+}
+
+#########################
+# LR0 States Generation #
+#########################
+#
+###########################
+# General digraph routine #
+###########################
+sub _Digraph {
+ my($rel,$F)=@_;
+ my(%N,@S);
+ my($infinity)=(~(1<<31));
+ my($Traverse);
+
+ $Traverse = sub {
+ my($x,$d)=@_;
+ my($y);
+
+ push(@S,$x);
+ $N{$x}=$d;
+
+ exists($$rel{$x})
+ and do {
+ for $y (keys(%{$$rel{$x}})) {
+ exists($N{$y})
+ or &$Traverse($y,$d+1);
+
+ $N{$y} < $N{$x}
+ and $N{$x} = $N{$y};
+
+ $$F{$x}|=$$F{$y};
+ }
+ };
+
+ $N{$x} == $d
+ and do {
+ for(;;) {
+ $y=pop(@S);
+ $N{$y}=$infinity;
+ $y eq $x
+ and last;
+ $$F{$y}=$$F{$x};
+ }
+ };
+ };
+
+ for (keys(%$rel)) {
+ exists($N{$_})
+ or &$Traverse($_,1);
+ }
+}
+#######################
+# Generate LR0 states #
+#######################
+=for nobody
+Formula used for closures:
+
+ CLOSE(A) = DCLOSE(A) u U (CLOSE(B) | A close B)
+
+where:
+
+ DCLOSE(A) = { [ A -> alpha ] in P }
+
+ A close B iff [ A -> B gamma ] in P
+
+=cut
+sub _SetClosures {
+ my($grammar)=@_;
+ my($rel,$closures);
+
+ for my $symbol (keys(%{$$grammar{NTERM}})) {
+ $closures->{$symbol}=pack('b'.@{$$grammar{RULES}});
+
+ for my $ruleno (@{$$grammar{NTERM}{$symbol}}) {
+ my($rhs)=$$grammar{RULES}[$ruleno][1];
+
+ vec($closures->{$symbol},$ruleno,1)=1;
+
+ @$rhs > 0
+ and exists($$grammar{NTERM}{$$rhs[0]})
+ and ++$rel->{$symbol}{$$rhs[0]};
+ }
+ }
+ _Digraph($rel,$closures);
+
+ $closures
+}
+
+sub _Closures {
+ my($grammar,$core,$closures)=@_;
+ my($ruleset)=pack('b'.@{$$grammar{RULES}});
+
+ for (@$core) {
+ my($ruleno,$pos)=@$_;
+ my($rhs)=$$grammar{RULES}[$ruleno][1];
+
+ $pos < @$rhs
+ and exists($closures->{$$rhs[$pos]})
+ and $ruleset|=$closures->{$$rhs[$pos]};
+ }
+ [ @$core, map { [ $_, 0 ] }
+ grep { vec($ruleset,$_,1) }
+ 0..$#{$$grammar{RULES}} ];
+}
+
+sub _Transitions {
+ my($grammar,$cores,$closures,$states,$stateno)=@_;
+ my($core)=$$states[$stateno]{'CORE'};
+ my(%transitions);
+
+ for (@{_Closures($grammar,$core,$closures)}) {
+ my($ruleno,$pos)=@$_;
+ my($rhs)=$$grammar{RULES}[$ruleno][1];
+
+ $pos == @$rhs
+ and do {
+ push(@{$$states[$stateno]{ACTIONS}{''}},$ruleno);
+ next;
+ };
+ push(@{$transitions{$$rhs[$pos]}},[ $ruleno, $pos+1 ]);
+ }
+
+ for (keys(%transitions)) {
+ my($symbol,$core)=($_,$transitions{$_});
+ my($corekey)=join(',',map { join('.',@$_) }
+ sort { $$a[0] <=> $$b[0]
+ or $$a[1] <=> $$b[1] }
+ @$core);
+ my($tostateno);
+
+ exists($cores->{$corekey})
+ or do {
+ push(@$states,{ 'CORE' => $core });
+ $cores->{$corekey}=$#$states;
+ };
+
+ $tostateno=$cores->{$corekey};
+ push(@{$$states[$tostateno]{FROM}},$stateno);
+
+ exists($$grammar{TERM}{$_})
+ and do {
+ $$states[$stateno]{ACTIONS}{$_} = [ $tostateno ];
+ next;
+ };
+ $$states[$stateno]{GOTOS}{$_} = $tostateno;
+ }
+}
+
+sub _LR0 {
+ my($grammar)=@_;
+ my($states) = [];
+ my($stateno);
+ my($closures); #$closures={ nterm => ruleset,... }
+ my($cores)={}; # { "itemlist" => stateno, ... }
+ # where "itemlist" has the form:
+ # "ruleno.pos,ruleno.pos" ordered by ruleno,pos
+
+ $closures = _SetClosures($grammar);
+ push(@$states,{ 'CORE' => [ [ 0, 0 ] ] });
+ for($stateno=0;$stateno<@$states;++$stateno) {
+ _Transitions($grammar,$cores,$closures,$states,$stateno);
+ }
+
+ $states
+}
+
+#########################################################
+# Add Lookahead tokens where needed to make LALR states #
+#########################################################
+=for nobody
+ Compute First sets for non-terminal using the following formula:
+
+ FIRST(A) = { a in T u { epsilon } | A l a }
+ u
+ U { FIRST(B) | B in V and A l B }
+
+ where:
+
+ A l x iff [ A -> X1 X2 .. Xn x alpha ] in P and Xi =>* epsilon, 1 <= i <= n
+=cut
+sub _SetFirst {
+ my($grammar,$termlst,$terminx)=@_;
+ my($rel,$first)=( {}, {} );
+
+ for my $symbol (keys(%{$$grammar{NTERM}})) {
+ $first->{$symbol}=pack('b'.@$termlst);
+
+ RULE:
+ for my $ruleno (@{$$grammar{NTERM}{$symbol}}) {
+ my($rhs)=$$grammar{RULES}[$ruleno][1];
+
+ for (@$rhs) {
+ exists($terminx->{$_})
+ and do {
+ vec($first->{$symbol},$terminx->{$_},1)=1;
+ next RULE;
+ };
+ ++$rel->{$symbol}{$_};
+ exists($$grammar{NULLABLE}{$_})
+ or next RULE;
+ }
+ vec($first->{$symbol},0,1)=1;
+ }
+ }
+ _Digraph($rel,$first);
+
+ $first
+}
+
+sub _Preds {
+ my($states,$stateno,$len)=@_;
+ my($queue, $preds);
+
+ $len
+ or return [ $stateno ];
+
+ $queue=[ [ $stateno, $len ] ];
+ while(@$queue) {
+ my($pred) = shift(@$queue);
+ my($stateno, $len) = @$pred;
+
+ $len == 1
+ and do {
+ push(@$preds,@{$states->[$stateno]{FROM}});
+ next;
+ };
+
+ push(@$queue, map { [ $_, $len - 1 ] }
+ @{$states->[$stateno]{FROM}});
+ }
+
+ # Pass @$preds through a hash to ensure unicity
+ [ keys( %{ +{ map { ($_,1) } @$preds } } ) ];
+}
+
+sub _FirstSfx {
+ my($grammar,$firstset,$termlst,$terminx,$ruleno,$pos,$key)=@_;
+ my($first)=pack('b'.@$termlst);
+ my($rhs)=$$grammar{RULES}[$ruleno][1];
+
+ for (;$pos < @$rhs;++$pos) {
+ exists($terminx->{$$rhs[$pos]})
+ and do {
+ vec($first,$terminx->{$$rhs[$pos]},1)=1;
+ return($first);
+ };
+ $first|=$firstset->{$$rhs[$pos]};
+
+ vec($first,0,1)
+ and vec($first,0,1)=0;
+
+ exists($$grammar{NULLABLE}{$$rhs[$pos]})
+ or return($first);
+
+ }
+ vec($first,0,1)=1;
+ $first;
+}
+
+=for noboby
+ Compute Follow sets using following formula:
+
+ FOLLOW(p,A) = READ(p,A)
+ u
+ U { FOLLOW(q,B) | (p,A) include (q,B)
+
+ where:
+
+ READ(p,A) = U { FIRST(beta) | [ A -> alpha A . beta ] in KERNEL(GOTO(p,A))
+ } - { epsilon }
+
+ (p,a) include (q,B) iff [ B -> alpha A . beta ] in KERNEL(GOTO(p,A),
+ epsilon in FIRST(beta) and
+ q in PRED(p,alpha)
+=cut
+sub _ComputeFollows {
+ my($grammar,$states,$termlst)=@_;
+ my($firstset,$terminx);
+ my($inconsistent, $rel, $follows, $sfx)= ( {}, {}, {}, {} );
+
+ %$terminx= map { ($termlst->[$_],$_) } 0..$#$termlst;
+
+ $firstset=_SetFirst($grammar,$termlst,$terminx);
+
+ for my $stateno (0..$#$states) {
+ my($state)=$$states[$stateno];
+
+ exists($$state{ACTIONS}{''})
+ and ( @{$$state{ACTIONS}{''}} > 1
+ or keys(%{$$state{ACTIONS}}) > 1 )
+ and do {
+ ++$inconsistent->{$stateno};
+
+ for my $ruleno (@{$$state{ACTIONS}{''}}) {
+ my($lhs,$rhs)=@{$$grammar{RULES}[$ruleno]}[0,1];
+
+ for my $predno (@{_Preds($states,$stateno,scalar(@$rhs))}) {
+ ++$rel->{"$stateno.$ruleno"}{"$predno.$lhs"};
+ }
+ }
+ };
+
+ exists($$state{GOTOS})
+ or next;
+
+ for my $symbol (keys(%{$$state{GOTOS}})) {
+ my($tostate)=$$states[$$state{GOTOS}{$symbol}];
+ my($goto)="$stateno.$symbol";
+
+ $follows->{$goto}=pack('b'.@$termlst);
+
+ for my $item (@{$$tostate{'CORE'}}) {
+ my($ruleno,$pos)=@$item;
+ my($key)="$ruleno.$pos";
+
+ exists($sfx->{$key})
+ or $sfx->{$key} = _FirstSfx($grammar,$firstset,
+ $termlst,$terminx,
+ $ruleno,$pos,$key);
+
+ $follows->{$goto}|=$sfx->{$key};
+
+ vec($follows->{$goto},0,1)
+ and do {
+ my($lhs)=$$grammar{RULES}[$ruleno][0];
+
+ vec($follows->{$goto},0,1)=0;
+
+ for my $predno (@{_Preds($states,$stateno,$pos-1)}) {
+ ++$rel->{$goto}{"$predno.$lhs"};
+ }
+ };
+ }
+ }
+ }
+ _Digraph($rel,$follows);
+
+ ($follows,$inconsistent)
+}
+
+sub _ComputeLA {
+ my($grammar,$states)=@_;
+ my($termlst)= [ '',keys(%{$$grammar{TERM}}) ];
+
+ my($follows,$inconsistent) = _ComputeFollows($grammar,$states,$termlst);
+
+ for my $stateno ( keys(%$inconsistent ) ) {
+ my($state)=$$states[$stateno];
+ my($conflict);
+
+ #NB the sort is VERY important for conflicts resolution order
+ for my $ruleno (sort { $a <=> $b }
+ @{$$state{ACTIONS}{''}}) {
+ for my $term ( map { $termlst->[$_] } grep {
+ vec($follows->{"$stateno.$ruleno"},$_,1) }
+ 0..$#$termlst) {
+ exists($$state{ACTIONS}{$term})
+ and ++$conflict;
+ push(@{$$state{ACTIONS}{$term}},-$ruleno);
+ }
+ }
+ delete($$state{ACTIONS}{''});
+ $conflict
+ or delete($inconsistent->{$stateno});
+ }
+
+ $inconsistent
+}
+
+#############################
+# Solve remaining conflicts #
+#############################
+
+sub _SolveConflicts {
+ my($grammar,$states,$inconsistent)=@_;
+ my(%rulesprec,$RulePrec);
+ my($conflicts)={ SOLVED => {},
+ FORCED => { TOTAL => [ 0, 0 ],
+ DETAIL => {}
+ }
+ };
+
+ $RulePrec = sub {
+ my($ruleno)=@_;
+ my($rhs,$rprec)=@{$$grammar{RULES}[$ruleno]}[1,2];
+ my($lastterm);
+
+ defined($rprec)
+ and return($rprec);
+
+ exists($rulesprec{$ruleno})
+ and return($rulesprec{$ruleno});
+
+ $lastterm=(grep { exists($$grammar{TERM}{$_}) } @$rhs)[-1];
+
+ defined($lastterm)
+ and ref($$grammar{TERM}{$lastterm})
+ and do {
+ $rulesprec{$ruleno}=$$grammar{TERM}{$lastterm}[1];
+ return($rulesprec{$ruleno});
+ };
+
+ undef;
+ };
+
+ for my $stateno (keys(%$inconsistent)) {
+ my($state)=$$states[$stateno];
+ my($actions)=$$state{ACTIONS};
+ my($nbsr,$nbrr);
+