Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Merge branch 'master' into gerd/JSON_nqp

  • Loading branch information...
commit 7ac0362f90918f50bc9700a098350c111c685538 2 parents 45e5941 + 0cf3ffa
Gerd Pokorra authored
Showing with 7,648 additions and 7,159 deletions.
  1. +10 −5 MANIFEST
  2. +11 −2 NEWS
  3. +10 −0 api.yaml
  4. +12 −0 compilers/data_json/JSON.nqp
  5. +72 −79 compilers/opsc/ops2c.nqp
  6. +418 −191 compilers/opsc/src/Ops/Compiler/Actions.pm
  7. +314 −41 compilers/opsc/src/Ops/Compiler/Grammar.pm
  8. +347 −44 compilers/opsc/src/Ops/Op.pm
  9. +1 −1  compilers/opsc/src/Ops/Trans/C.pm
  10. +8 −9 config/auto/coverage.pm
  11. +66 −0 config/auto/infnan.pm
  12. +26 −0 config/auto/infnan/test_c.in
  13. +114 −111 config/auto/sizes.pm
  14. +0 −24 config/auto/sizes/floatval_maxmin_c.in
  15. +0 −25 config/auto/sizes/intval_maxmin_c.in
  16. +0 −29 config/auto/sizes/test2_c.in
  17. +0 −22 config/auto/sizes/test3_c.in
  18. +3 −17 config/auto/sizes/test_c.in
  19. +5 −20 config/gen/config_h/config_h.in
  20. +1 −1  config/gen/config_pm/myconfig.in
  21. +8 −0 config/gen/makefiles/root.in
  22. +19 −4 docs/project/release_manager_guide.pod
  23. +25 −0 include/parrot/api.h
  24. +24 −16 include/parrot/datatypes.h
  25. +2 −10 include/parrot/multidispatch.h
  26. +24 −24 include/parrot/pmc.h
  27. +50 −0 include/parrot/thr_none.h
  28. +8 −43 include/parrot/thread.h
  29. +1 −0  lib/Parrot/Configure/Step/List.pm
  30. +1 −1  lib/Parrot/Harness/Smoke.pm
  31. +12 −5 lib/Parrot/Pmc2c/PCCMETHOD.pm
  32. +2 −4 lib/Parrot/Pmc2c/PMC.pm
  33. +11 −12 src/call/args.c
  34. +10 −1 src/call/context.c
  35. +3 −3 src/call/pcc.c
  36. +4 −0 src/datatypes.c
  37. +65 −0 src/embed/api.c
  38. +4 −4 src/gc/gc_gms.c
  39. +5 −7 src/interp/inter_create.c
  40. +6 −25 src/multidispatch.c
  41. +4,862 −6,110 src/ops/core_ops.c
  42. +3 −3 src/pmc.c
  43. +24 −26 src/pmc/role.pmc
  44. +5 −6 src/pmc/scalar.pmc
  45. +9 −8 src/pmc/scheduler.pmc
  46. +5 −6 src/pmc/sockaddr.pmc
  47. +13 −13 src/pmc/socket.pmc
  48. +9 −12 src/pmc/string.pmc
  49. +9 −5 src/pmc/stringbuilder.pmc
  50. +2 −2 src/pmc/stringhandle.pmc
  51. +4 −4 src/pmc/stringiterator.pmc
  52. +15 −29 src/pmc/structview.pmc
  53. +7 −3 src/pmc/task.pmc
  54. +7 −4 src/pmc/timer.pmc
  55. +20 −3 src/pmc/undef.pmc
  56. +21 −13 src/pmc/unmanagedstruct.pmc
  57. +3 −3 src/spf_render.c
  58. +436 −0 t/compilers/opsc/01-parse-body.t
  59. +98 −0 t/compilers/opsc/03-past-declarator.t
  60. +22 −0 t/compilers/opsc/03-past-macros.t
  61. +8 −12 t/compilers/opsc/03-past.t
  62. +144 −0 t/compilers/opsc/07-op-to-c.t
  63. +2 −2 t/compilers/opsc/{07-emitter.t → 08-emitter.t}
  64. +3 −2 t/compilers/opsc/common.pir
  65. +3 −6 t/op/exit.t
  66. +14 −105 t/steps/auto/sizes-01.t
  67. +4 −2 t/tools/dev/headerizer/01_functions.t
  68. +136 −0 tools/dev/dedeprecator
  69. +58 −0 tools/release/releasecheck.pl
View
15 MANIFEST
@@ -157,6 +157,8 @@ config/auto/gmp/gmp_c.in []
config/auto/headers.pm []
config/auto/headers/test_c.in []
config/auto/icu.pm []
+config/auto/infnan.pm []
+config/auto/infnan/test_c.in []
config/auto/inline.pm []
config/auto/inline/test1_c.in []
config/auto/inline/test2_c.in []
@@ -193,10 +195,6 @@ config/auto/signal/test1_c.in []
config/auto/signal/test2_c.in []
config/auto/signal/test_itimer_c.in []
config/auto/sizes.pm []
-config/auto/sizes/floatval_maxmin_c.in []
-config/auto/sizes/intval_maxmin_c.in []
-config/auto/sizes/test2_c.in []
-config/auto/sizes/test3_c.in []
config/auto/sizes/test_c.in []
config/auto/snprintf.pm []
config/auto/snprintf/test_c.in []
@@ -928,6 +926,7 @@ include/parrot/settings.h [main]include
include/parrot/string.h [main]include
include/parrot/string_funcs.h [main]include
include/parrot/sub.h [main]include
+include/parrot/thr_none.h [main]include
include/parrot/thr_pthread.h [main]include
include/parrot/thr_windows.h [main]include
include/parrot/thread.h [main]include
@@ -1508,13 +1507,17 @@ t/compilers/imcc/syn/subflags.t [test]
t/compilers/imcc/syn/symbols.t [test]
t/compilers/imcc/syn/tail.t [test]
t/compilers/imcc/syn/veracity.t [test]
+t/compilers/opsc/01-parse-body.t [test]
t/compilers/opsc/01-parse.t [test]
t/compilers/opsc/02-parse-all-ops.t [test]
+t/compilers/opsc/03-past-declarator.t [test]
+t/compilers/opsc/03-past-macros.t [test]
t/compilers/opsc/03-past.t [test]
t/compilers/opsc/04-op.t [test]
t/compilers/opsc/05-oplib.t [test]
t/compilers/opsc/06-opsfile.t [test]
-t/compilers/opsc/07-emitter.t [test]
+t/compilers/opsc/07-op-to-c.t [test]
+t/compilers/opsc/08-emitter.t [test]
t/compilers/opsc/common.pir [test]
t/compilers/pct/complete_workflow.t [test]
t/compilers/pct/past.t [test]
@@ -2109,6 +2112,7 @@ tools/dev/as2c.pl []
tools/dev/bench_op.pir []
tools/dev/create_language.pl [devel]
tools/dev/debian_docs.sh []
+tools/dev/dedeprecator []
tools/dev/dump_pbc.pl []
tools/dev/faces.pl []
tools/dev/fetch_languages.pl []
@@ -2179,6 +2183,7 @@ tools/release/crow.pir []
tools/release/gen_release_info.pl []
tools/release/inc_ver.pir []
tools/release/release.json []
+tools/release/releasecheck.pl []
tools/release/templates.json []
# Local variables:
# mode: text
View
13 NEWS
@@ -2,20 +2,29 @@ New in 3.2.0
- Core
+ Full support for Unicode filenames on Linux and Win32
+ The configuration option --cxx is gone
- + Improved code coverage
+ New Generational GC implemented. To enable it run Configure.pl --gc=gms
+ "opsc_full_parse" branch for semantically parse of ops is started
- + Parallel building is supported ( make -j<number> )
+ + A statement convert the '.param' PIR systax
+ + A PMC is implemented for low-level buffer access which separate the
+ representation from the pointers
+ + Support added for 'long double', 'long long', and 64-bit to StructView
- Languages
+ A few tests in Cardinal are fixed
+ Minor fixes, refactors and cleaning on Winxed
+ New predefs replace and push on Winxed
+ + Operators exits, class and .* (indirect method call) added on Winxed
+ + $loadlib directive for Winxed
+ + -o option to installable driver added on Winxed
- Community
+ + M0 roadmap is in progress
- Documentation
+ 'make docs' target, which was serving only to generate superfluous POD
files, has been removed.
+ Svn remnants from PDDs are removed
- Tests
+ + Added 'make release_check' target so that Release Manager can double-check
+ tarball
+ + Probes added for 'long long' and 64-bit C types
New in 3.1.0
- Core
View
10 api.yaml
@@ -1,5 +1,9 @@
---
-
+ name: 'Pointer, UnManagedStruct, and ManagedStruct'
+ eligible: '3.4'
+ ticket: 'http://trac.parrot.org/parrot/ticket/2035'
+-
name: 'add write barrier to all PMCs that write in unusual VTABLE functions'
eligible: '3.4'
note: 'VTABLE functions not marked with :write that mutate the PMCs need to use the write barrier. See ticket for more information.'
@@ -15,6 +19,9 @@
- 'PIR'
- 'syntax'
- 'deprecated'
+ detection:
+ regex:
+ pir: '^ ".sub" .+ ":init"'
ticket: 'https://trac.parrot.org/parrot/ticket/1896'
-
name: '":load" and ":init" Sub flags doing different things'
@@ -77,6 +84,9 @@
tags:
- 'deprecated'
- 'PMC'
+ detection:
+ regex:
+ pir: 'new\s\[?\''Complex\''\]?'
ticket: 'https://trac.parrot.org/parrot/ticket/1892'
-
name: 'Cross-HLL library loading'
View
12 compilers/data_json/JSON.nqp
@@ -66,6 +66,14 @@ grammar JSON::Grammar is HLL::Grammar {
'}'
}
+ rule value:sym<true> {
+ 'true'
+ }
+
+ rule value:sym<false> {
+ 'false'
+ }
+
token string {
<?["]> <quote_EXPR: ':qq'>
}
@@ -108,6 +116,10 @@ class JSON::Actions is HLL::Actions {
make $past;
}
+ method value:sym<true>($/) { make 1; }
+
+ method value:sym<false>($/) { make 0; }
+
method string($/) { make $<quote_EXPR>.ast; }
}
View
151 compilers/opsc/ops2c.nqp
@@ -14,48 +14,19 @@ sub MAIN() {
pir::load_bytecode("opsc.pbc");
pir::load_bytecode("Getopt/Obj.pbc");
- my $core := 0;
- my @files;
- my $emit_lines := 1;
+ my $opts := get_options();
- my $getopts := Q:PIR{ %r = new ['Getopt';'Obj'] };
+ return usage() if $opts<help>;
- $getopts.notOptStop();
+ #TODO: figure out how to generate line numbers
+ # $emit_lines is currently ignored
+ my $emit_lines := !?$opts<no-lines>;
+ my $core := ?$opts<core>;
+ my $debug := ?$opts<debug>;
+ my $quiet := ?$opts<quiet>;
- # build core ops
- my $arg := $getopts.add();
- $arg.long('core');
- $arg.short('c');
-
- # build the dynops in one .ops file
- $arg := $getopts.add();
- $arg.long('dynamic');
- $arg.short('d');
- $arg.type('String');
-
- # don't write to any files
- $arg := $getopts.add();
- $arg.long('debug');
- $arg.short('g');
-
- # don't add line numbers to generated files (not implemented)
- $arg := $getopts.add();
- $arg.long('no-lines');
- $arg.short('n');
-
- # print anemic usage information and exit
- $arg := $getopts.add();
- $arg.long('help');
- $arg.short('h');
-
- # suppress timing and debug output on stdout
- $arg := $getopts.add();
- $arg.long('quiet');
- $arg.short('q');
-
- my $opts := $getopts.get_options(pir::getinterp__p()[2]);
-
- if $opts<core> {
+ my @files;
+ if $core {
@files := <
src/ops/core.ops
src/ops/bit.ops
@@ -70,53 +41,26 @@ sub MAIN() {
src/ops/var.ops
src/ops/experimental.ops
>;
- $core := 1;
}
elsif $opts<dynamic> {
- $core := 0;
@files.push( $opts<dynamic>);
}
- elsif (+$opts == 0 || $opts<help>) {
- say("This is ops2c, part of the Parrot VM's build infrastructure.
- normal options:
- -c --core generate the C code for core ops (must be run from within Parrot's build directory)
- -d --dynamic <file.ops> generate the C code for the dynamic ops in a single .ops file
- -q --quiet don't report any non-error messages
- -h --help print this usage information
- -n --no-lines do not print #line directives in generated C code (line numbers are not currently supported)
-
- debugging options:
- -g --debug perform all processing but do not write to any files
- ");
- pir::exit(0);
- }
-
- if ($opts<no-lines>) {
- #TODO: figure out how to generate line numbers
- # $emit_lines is currently ignored
- $emit_lines := 0;
+ else {
+ return usage();
}
my $trans := Ops::Trans::C.new();
my $start_time := pir::time__N();
- my $debug := ?$opts<debug>;
- my $quiet := ?$opts<quiet>;
- my $f;
- my $renum;
+ my $lib := $core
+ ?? Ops::OpLib.new(
+ :skip_file('src/ops/ops.skip'),
+ :quiet($quiet)
+ )
+ !! undef;
- if $core {
- my $lib := Ops::OpLib.new(
- :skip_file('src/ops/ops.skip'),
- :quiet($quiet)
- );
- $f := Ops::File.new(|@files, :oplib($lib), :core(1), :quiet($quiet));
- }
- else {
- $f := Ops::File.new(|@files, :core(0), :quiet($quiet));
- }
+ my $f := Ops::File.new(|@files, :oplib($lib), :core($core), :quiet($quiet));
- pir::sprintf(my $time, "%.3f", [pir::time__N() - $start_time] );
- $quiet || say("# Ops parsed in $time seconds.");
+ $quiet || say("# Ops parsed in { pir::sprintf__ssp("%.3f", [pir::time__N() - $start_time] ) } seconds.");
my $emitter := Ops::Emitter.new(
:ops_file($f), :trans($trans),
@@ -125,12 +69,61 @@ sub MAIN() {
);
unless $debug {
- if $core {
- $emitter.print_ops_num_files();
- }
+ $emitter.print_ops_num_files() if $core;
$emitter.print_c_header_files();
$emitter.print_c_source_file();
}
}
+sub get_options() {
+ my $getopts := pir::new(Getopt::Obj);
+
+ $getopts.notOptStop();
+
+ # build core ops
+ $getopts.add_option('core', 'c');
+
+ # build the dynops in one .ops file
+ $getopts.add_option('dynamic', 'd', 'String');
+
+ # don't write to any files
+ $getopts.add_option('debug', 'g');
+
+ # don't add line numbers to generated files (not implemented)
+ $getopts.add_option('no-lines', 'n');
+
+ # print anemic usage information and exit
+ $getopts.add_option('help', 'h');
+
+ # suppress timing and debug output on stdout
+ $getopts.add_option('quiet', 'q');
+
+ $getopts.get_options(pir::getinterp__p()[2]);
+}
+
+sub usage() {
+ say("This is ops2c, part of the Parrot VM's build infrastructure.
+ normal options:
+ -c --core generate the C code for core ops (must be run from within Parrot's build directory)
+ -d --dynamic <file.ops> generate the C code for the dynamic ops in a single .ops file
+ -q --quiet don't report any non-error messages
+ -h --help print this usage information
+ -n --no-lines do not print #line directives in generated C code (line numbers are not currently supported)
+
+ debugging options:
+ -g --debug perform all processing but do not write to any files
+ ");
+ pir::exit(0);
+}
+
+# Monkey patching
+module Getopt::Obj {
+ multi method add_option($long, $short, $type?) {
+ my $opt := self.add();
+ $opt.long($long);
+ $opt.short($short);
+ $opt.type($type) if $type;
+ }
+}
+
# vim: expandtab shiftwidth=4 ft=perl6:
View
609 compilers/opsc/src/Ops/Compiler/Actions.pm
@@ -3,6 +3,7 @@
class Ops::Compiler::Actions is HLL::Actions;
+our $OP;
our $OPLIB;
INIT {
@@ -54,85 +55,83 @@ method preamble($/) {
);
}
-method op($/) {
+method op ($/, $key?) {
- # Handling flags.
- my %flags := hash();
- for $<op_flag> {
- %flags{~$_<identifier>} := 1;
- }
-
- my @args := @($<signature>.ast);
+ if $key eq 'start' {
+ # Handling flags.
+ my %flags := hash();
+ for $<op_flag> {
+ %flags{~$_<identifier>} := 1;
+ }
- my @norm_args := normalize_args(@args);
- # We have to clone @norm_args. Otherwise it will be destroyed...
- my @variants := expand_args(pir::clone__PP(@norm_args));
+ my @args := @($<signature>.ast);
+ my @norm_args := normalize_args(@args);
- my $op := Ops::Op.new(
- :name(~$<op_name>),
- );
+ $OP := Ops::Op.new(
+ :name(~$<op_name>),
+ );
- # Flatten PAST::Stmts into Op.
- for @($<op_body>.ast) {
- $op.push($_);
- }
+ if ~$<op_name> eq 'runinterp' {
+ $OP.add_jump('PARROT_JUMP_RELATIVE');
+ }
- for $<op_body>.ast<jump> {
- $op.add_jump($_);
- }
- if ~$<op_name> eq 'runinterp' {
- $op.add_jump('PARROT_JUMP_RELATIVE');
- }
- $op<flags> := %flags;
- $op<args> := @args;
- $op<type> := ~$<op_type>;
- $op<normalized_args> := @norm_args;
-
- if $op.need_write_barrier {
- $op.push(PAST::Op.new(
- :pasttype<inline>,
- :inline(" PARROT_GC_WRITE_BARRIER(interp, CURRENT_CONTEXT(interp));\n")
- ));
+ $OP<flags> := %flags;
+ $OP<args> := @args;
+ $OP<type> := ~$<op_type>;
+ $OP<normalized_args> := @norm_args;
}
+ else {
+ # Handle op body
+ $OP.push($<op_body>.ast);
+
+ if $OP.need_write_barrier {
+ $OP[0].push(
+ PAST::Op.new(
+ :pasttype<call>,
+ :name<PARROT_GC_WRITE_BARRIER>,
+ PAST::Var.new(
+ :name<interp>
+ ),
+ PAST::Op.new(
+ :pasttype<call>,
+ :name<CURRENT_CONTEXT>,
+ PAST::Var.new(
+ :name<interp>
+ )
+ )
+ )
+ );
+ }
- if !%flags<flow> {
- my $goto_next := PAST::Op.new(
- :pasttype('call'),
- :name('goto_offset'),
- PAST::Op.new(
- :pasttype<call>,
- :name<OPSIZE>,
- )
- );
+ if !$OP<flags><flow> {
+ my $goto_next := PAST::Op.new(
+ :pasttype('macro'),
+ :name('goto_offset'),
+ self.opsize,
+ );
- my $nl := "\n";
- $op.push(PAST::Op.new(
- :pasttype<inline>,
- :inline($nl)
- ));
- $op.push($goto_next);
- $op.push(PAST::Op.new(
- :pasttype<inline>,
- :inline(";\n"),
- ));
- }
+ $OP[0].push($goto_next);
+ }
- my $past := PAST::Stmts.new(
- :node($/)
- );
+ my $past := PAST::Stmts.new(
+ :node($/)
+ );
- if @variants {
- for @variants {
- my $new_op := pir::clone__PP($op);
- $new_op<arg_types> := $_;
- $past.push($new_op);
+ # We have to clone @norm_args. Otherwise it will be destroyed...
+ my @variants := expand_args(pir::clone__PP($OP<normalized_args>));
+ if @variants {
+ for @variants {
+ my $new_op := pir::clone__PP($OP);
+ $new_op<arg_types> := $_;
+ $past.push($new_op);
+ }
+ }
+ else {
+ $past.push($OP);
}
- }
- else {
- $past.push($op);
- }
- make $past;
+ make $past;
+ }
}
# Normalize args
@@ -253,160 +252,388 @@ method op_param($/) {
}
method op_body($/) {
+ make $<blockoid>.ast;
+}
+
+method op_macro:sym<expr offset>($/) {
+ make PAST::Op.new(
+ :pasttype<macro>,
+ :name<expr_offset>,
+ $<arg>.ast,
+ );
+}
+
+method op_macro:sym<goto offset>($/) {
+ make PAST::Op.new(
+ :pasttype<macro>,
+ :name<goto_offset>,
+ $<arg>.ast,
+ );
+
+ $OP.add_jump('PARROT_JUMP_RELATIVE');
+}
+
+method op_macro:sym<expr address>($/) {
+ make PAST::Op.new(
+ :pasttype<macro>,
+ :name<expr_address>,
+ $<arg>.ast,
+ );
+}
+
+method op_macro:sym<goto address>($/) {
+ make PAST::Op.new(
+ :pasttype<macro>,
+ :name<goto_address>,
+ $<arg>.ast,
+ );
+}
+
+method op_macro:sym<expr next>($/) {
+ my $past := PAST::Op.new(
+ :pasttype<macro>,
+ :name<expr_offset>,
+ self.opsize,
+ );
+
+ make $past;
+}
+
+method op_macro:sym<goto next>($/) {
+ my $past := PAST::Op.new(
+ :pasttype<macro>,
+ :name<goto_offset>,
+ self.opsize,
+ );
+
+ $OP.add_jump('PARROT_JUMP_RELATIVE');
+
+ make $past;
+}
+
+
+method op_macro:sym<restart next> ($/) {
+ #say('# op_macro');
+ # restart NEXT() -> restart_offset(opsize()); goto_address(0)
my $past := PAST::Stmts.new(
- :node($/),
+ PAST::Op.new(
+ :pasttype<macro>,
+ :name<restart_offset>,
+ self.opsize,
+ ),
+ PAST::Op.new(
+ :pasttype<macro>,
+ :name<goto_address>,
+ PAST::Val.new(
+ :value<0>
+ )
+ ),
);
- $past<jump> := list();
- my $prev_words := '';
- for $<body_word> {
- if $prev_words && $_<word> {
- $prev_words := $prev_words ~ ~$_<word>;
- }
- elsif $_<word> {
- $prev_words := ~$_<word>;
- }
- else {
- $past.push(PAST::Op.new(
- :pasttype('inline'),
- :inline($prev_words),
- ));
- $prev_words := '';
-
- if $_<macro_param> {
- $past.push($_<macro_param>.ast);
- }
- elsif $_<op_macro> {
- $past.push($_<op_macro>.ast);
- for $_<op_macro>.ast<jump> {
- $past<jump>.push($_);
- }
- }
- }
- }
- if $prev_words {
- $past.push(PAST::Op.new(
- :pasttype('inline'),
- :inline($prev_words)
- ));
+
+ make $past;
+}
+
+method blockoid ($/) {
+ my $past := PAST::Block.new(:node($/));
+
+ $past.push($_) for @($<mixed_content>.ast);
+
+ make $past;
+}
+
+method mixed_content ($/) {
+ my $past := PAST::Stmts.new(:node($/));
+
+ @($_.ast).map(-> $_ { $past.push($_) }) for $<declarator>;
+ $past.push($_) for @($<statement_list>.ast);
+
+ make $past;
+}
+
+method declarator ($/) {
+ my $past := PAST::Stmts.new(:node($/));
+ for $<declarator_name> {
+ my $decl := PAST::Var.new(
+ :node($_),
+ :isdecl(1),
+ :name(~$_<variable>),
+ :vivibase(~$<type_declarator>),
+ );
+
+ $decl.viviself($_<EXPR>[0].ast) if $_<EXPR>[0];
+
+ $decl<array_size> := ~$_<array_size><VALUE> if $_<array_size>;
+ $decl<pointer> := $_<pointer>.join('');
+ $past.push($decl);
}
+
make $past;
}
-method macro_param($/) {
- make PAST::Var.new(
- :name(~$<num>),
- :node($/),
- );
+method statement_list ($/) {
+ my $past := PAST::Stmts.new(:node($/));
+
+ $past.push($_.ast) for $<labeled_statement>;
+
+ # Avoid wrapping single blockoid into Stmts.
+ make (+@($past) == 1) && ($past[0] ~~ PAST::Block)
+ ?? $past[0]
+ !! $past;
}
-method body_word($/) {
- #say('# body_word: '~ ~$<word>);
+method labeled_statement ($/) {
+ # FIXME!!!
+ my $past := $<statement>
+ ?? $<statement>.ast
+ !! PAST::Op.new();
+
+ # FIXME!!! We need some semantics here.
+ $past<label> := ~$<label> if $<label>;
+
+ make $past;
+}
+
+method statement ($/) {
my $past;
- if $<word> {
- $past := PAST::Op.new(
- :pasttype('inline'),
- :inline(~$<word>)
- );
+
+ if $<statement_control> {
+ $past := $<statement_control>.ast;
}
- elsif $<macro_param> {
- $past := $<macro_param>.ast;
+ elsif $<blockoid> {
+ $past := $<blockoid>.ast;
}
- elsif $<op_macro> {
- $past := $<op_macro>.ast;
+ elsif $<EXPR> {
+ $past := $<EXPR>.ast;
+ }
+ elsif $<c_macro> {
+ $past := $<c_macro>.ast;
}
else {
- die('horribly');
+ $/.CURSOR.panic("Unknown content in statement");
}
- #_dumper($past);
+
make $past;
}
-method op_macro($/) {
- #say('# op_macro');
- # Generate set of calls to Trans:
- # goto NEXT() -> goto_offset(opsize())
- # goto OFFSET($addr) -> goto_offset($addr)
- # goto ADDRESS($addr) -> goto_address($addr)
- # expr NEXT() -> expr_offset(opsize())
- # expr OFFSET($addr) -> expr_offset($addr)
- # expr ADDRERR($addr) -> expr_address($addr)
- # restart NEXT() -> restart_offset(opsize()); goto_address(0)
- # restart OFFSET() -> restart_offset($addr); goto_offset($addr)
- # XXX In trunk "restart ADDRESS" equivalent of "goto ADDRESS".
- # restart ADDRESS() -> restart_address($addr); goto_address($addr)
+method c_macro:sym<define> ($/) {
+ my $past := PAST::Op.new(
+ :pasttype<macro_define>,
+ $<name>,
+ );
+
+ $past<macro_args> := $<c_macro_args>[0].ast if $<c_macro_args>;
+ $past<body> := $<body>[0].ast if $<body>;
- my $macro_type := ~$<macro_type>;
- my $macro_dest := ~$<macro_destination>;
- my $is_next := $macro_dest eq 'NEXT';
- my $macro_name := $macro_type ~ '_' ~ lc($is_next ?? 'offset' !! $macro_dest);
+ make $past;
+}
- my $past := PAST::Stmts.new;
+method c_macro:sym<if> ($/) {
+ my $past := PAST::Op.new(
+ :pasttype<macro_if>,
- my $macro := PAST::Op.new(
- :pasttype('call'),
- :name($macro_name),
+ ~$<condition>, # FIXME! We have to parse condition somehow.
+ $<then>.ast,
);
- $past.push($macro);
- $past<jump> := list();
+ $past.push($<else>[0].ast) if $<else>;
- if $macro_type ne 'expr' && $macro_dest eq 'OFFSET' {
- $past<jump>.push('PARROT_JUMP_RELATIVE');
- }
+ make $past;
+}
- if $macro_type eq 'expr' || $macro_type eq 'goto' {
- if $is_next {
- $macro.push(PAST::Op.new(
- :pasttype<call>,
- :name<OPSIZE>,
- ));
- }
- else {
- process_op_macro_body_word($/, $macro);
- }
- }
- elsif $macro_type eq 'restart' {
- if $is_next {
- $macro.push(PAST::Op.new(
- :pasttype<call>,
- :name<OPSIZE>,
- ));
- }
- else {
- process_op_macro_body_word($/, $macro);
- }
+method c_macro:sym<ifdef> ($/) {
+ my $past := PAST::Op.new(
+ :pasttype<macro_if>,
- $macro := PAST::Op.new(
- :pasttype<call>,
- :name<goto_address>,
- );
- if $is_next {
- $macro.push(PAST::Op.new(
- :pasttype<inline>,
- :inline<0>,
- ));
- }
- else {
- process_op_macro_body_word($/, $macro);
- }
- $past.push($macro);
- }
- else {
- pir::die("Horribly");
- }
+ 'defined(' ~ ~$<name> ~ ')', # FIXME! We have to parse condition somehow.
+ $<then>.ast,
+ );
+
+ $past.push($<else>[0].ast) if $<else>;
make $past;
}
-sub process_op_macro_body_word($/, $macro) {
- #_dumper($<body_word>);
- if $<body_word> {
- for $<body_word> {
- #say(' word ' ~ $_);
- my $bit := $_.ast;
- $macro.push($_.ast) if defined($bit);
- }
+method term:sym<concatenate_strings> ($/) {
+ make ~$<identifier> ~ ' ' ~ ~$<quote>;
+}
+
+method term:sym<identifier> ($/) {
+ # XXX Type vs Variable
+ make PAST::Var.new(
+ :name(~$/),
+ );
+}
+
+method term:sym<call> ($/) {
+ my $past := PAST::Op.new(
+ :pasttype('call'),
+ :name(~$<identifier>),
+ );
+
+ if ($<arglist><arg>) {
+ $past.push($_.ast) for $<arglist><arg>;
}
+
+ make $past;
+}
+
+method arg ($/) {
+ make $<type_declarator>
+ ?? ~$<type_declarator>
+ !! $<EXPR>.ast;
+}
+
+method term:sym<reg> ($/) {
+ make PAST::Var.new(
+ :name(+$<num>),
+ :node($/),
+ :scope('register'), # Special scope
+ );
+}
+
+method term:sym<macro> ($/) {
+ make $<op_macro>.ast;
+}
+
+method term:sym<int> ($/) {
+ # TODO Handle type
+ make PAST::Val.new(
+ :value(~$/),
+ :returns<int>
+ );
+}
+
+method term:sym<str> ($/) {
+ make PAST::Val.new(
+ :value(~$<quote>),
+ :returns<string>
+ );
+}
+
+method term:sym<float_constant_long> ($/) { # longer to work-around lack of LTM
+ make PAST::Val.new(
+ :value(~$/),
+ :returns<float>
+ );
+}
+
+method infix:sym<?:> ($/) {
+ my $past := PAST::Op.new(
+ :pasttype<if>,
+ );
+ # Override to emit ternary ops in .to_c
+ $past<ternary> := 1;
+ make $past;
+}
+
+method statement_control:sym<if> ($/) {
+ my $past := PAST::Op.new(
+ :pasttype<if>,
+
+ $<EXPR>.ast,
+ $<then>.ast,
+ );
+
+ $past.push($<else>[0].ast) if $<else>;
+
+ make $past;
+}
+
+method statement_control:sym<while> ($/) {
+ my $past := PAST::Op.new(
+ :pasttype<while>,
+
+ $<condition>.ast,
+ $<statement_list>.ast,
+ );
+
+ make $past;
+}
+
+method statement_control:sym<do-while> ($/) {
+ my $past := PAST::Op.new(
+ :pasttype<do-while>,
+
+ $<blockoid>.ast,
+ $<condition>.ast,
+ );
+
+ make $past;
+}
+
+method statement_control:sym<for> ($/) {
+ my $past := PAST::Op.new(
+ :pasttype<for>,
+
+ $<init> ?? $<init>[0].ast !! undef,
+ $<test> ?? $<test>[0].ast !! undef,
+ $<step> ?? $<step>[0].ast !! undef,
+ $<statement_list>.ast,
+ );
+
+ make $past;
+}
+
+# Not real "C" switch. Just close enough
+method statement_control:sym<switch> ($/) {
+ my $past := PAST::Op.new(
+ :pasttype<switch>,
+ $<test>.ast,
+ $<statement_list>.ast,
+ );
+ make $past;
+}
+
+method statement_control:sym<break> ($/) {
+ my $past := PAST::Op.new();
+ $past<control> := 'break';
+ make $past;
+}
+
+method statement_control:sym<continue> ($/) {
+ my $past := PAST::Op.new();
+ $past<control> := 'continue';
+ make $past;
+}
+
+method statement_or_block ($/) {
+ $<labeled_statement>
+ ?? make PAST::Block.new(
+ $<labeled_statement>.ast
+ )
+ !! make $<blockoid>.ast
+}
+
+method circumfix:sym<( )> ($/) {
+ my $past := $<EXPR>.ast;
+
+ # Indicate that we need wrapping.
+ $past<wrap> := 1;
+
+ make $past;
+}
+
+method postcircumfix:sym<[ ]> ($/) {
+ make PAST::Var.new(
+ $<EXPR>.ast,
+ :scope('keyed'),
+ );
+}
+
+
+# For casting we just set "returns" of EXPR.
+method prefix:sym<( )> ($/) {
+ make PAST::Op.new(
+ :returns(~$<type_declarator>),
+ );
+}
+
+# Helper method for generating PAST::Val with opsize
+method opsize () {
+ make PAST::Val.new(
+ :value($OP.size),
+ :returns('int'),
+ );
}
# Local Variables:
View
355 compilers/opsc/src/Ops/Compiler/Grammar.pm
@@ -1,5 +1,5 @@
#! nqp
-# Copyright (C) 2009-2010, Parrot Foundation.
+# Copyright (C) 2009-2011, Parrot Foundation.
INIT { pir::load_bytecode('HLL.pbc'); }
@@ -7,11 +7,18 @@ grammar Ops::Compiler::Grammar is HLL::Grammar;
rule TOP {
<body>
+ <.pod_ws>
[ $ || <.panic: 'Syntax error'> ]
}
rule body {
- [ <preamble> | <op> ]*
+ [
+ <.pod_ws>
+ [
+ | <preamble>
+ | <op>
+ ]
+ ]*
}
token preamble {
@@ -33,11 +40,11 @@ token end_preamble {
}
rule op {
- <op_type>? 'op' <op_name=identifier>
+ <op_type>? 'op' <op_name=ident>
[ '(' <signature> ')' || <.panic: "Fail to parse signature"> ]
<op_flag>*
+ {*} #= start
[ <op_body> || <.panic: "Fail to parse op body"> ]
- {*}
}
token op_type {
@@ -79,72 +86,338 @@ rule op_flag {
}
# OpBody starts with '{' and ends with single '}' on line.
-regex op_body {
- '{'
- <body_word>*?
- ^^ '}'
+token op_body {
+ #<?DEBUG>
+ <blockoid>
+}
+
+proto token quote { <...> }
+token quote:sym<apos> { <?[']> <quote_EXPR: ':q'> }
+token quote:sym<dblq> { <?["]> <quote_EXPR: ':q'> }
+
+proto rule op_macro { <...> }
+rule op_macro:sym<goto offset> { 'goto' 'OFFSET' '(' <arg=.EXPR> ')' }
+rule op_macro:sym<expr offset> { 'expr' 'OFFSET' '(' <arg=.EXPR> ')' }
+rule op_macro:sym<goto address> { 'goto' 'ADDRESS' '(' <arg=.EXPR> ')' }
+rule op_macro:sym<expr address> { 'expr' 'ADDRESS' '(' <arg=.EXPR> ')' }
+rule op_macro:sym<goto next> { 'goto' 'NEXT' '(' ')' }
+rule op_macro:sym<expr next> { 'expr' 'NEXT' '(' ')' }
+rule op_macro:sym<restart next> { 'restart' 'NEXT' '(' ')' }
+
+proto rule c_macro { <...> }
+
+token c_macro:sym<define> {
+ ^^ '#' \h* <sym> \h+ <name=.identifier> <c_macro_args>? <body=.nonl>?
}
-#Process op body by breaking it into "words" consisting entirely of whitespace,
-#alnums or a single punctuation, then checking for interesting macros (e.g $1
-#or goto NEXT() ) in the midst of the words.
-token body_word {
+token c_macro:sym<ifdef> {
+ ^^ '#' \h* <sym> \h+ <name=.identifier> <.ws>
+ <then=.mixed_content>
[
- || <macro_param>
- || <op_macro>
- || <word>
- ]
+ ^^ '#' 'else' <else=.mixed_content>
+ ]?
+ ^^ '#' 'endif'
}
-token word {
- || <quote>
- || <ident>
- || <alnum>
- || <punct>
- || <ws>
+token c_macro:sym<if> {
+ ^^ '#' \h* <sym> \h+ <condition=.nonl> <.ws>
+ <then=.mixed_content>
+ [
+ ^^ '#' 'else' <else=.mixed_content>
+ ]?
+ ^^ '#' 'endif'
}
-proto token quote { <...> }
-token quote:sym<apos> { <?[']> <quote_EXPR: ':q'> }
-token quote:sym<dblq> { <?["]> <quote_EXPR: ':q'> }
-token macro_param {
- '$' $<num>=<integer> # Up to nine params.
+token c_macro_args {
+ '(' \h* <arg=.identifier>? [ \h* ',' \h* <arg=.identifier> ]* \h* ')'
}
-rule op_macro {
- <macro_type> <macro_destination> '(' <body_word>*? ')'
+token nonl {
+ \N+
}
-token macro_type {
+
+token identifier {
+ <!keyword> <ident>
+}
+
+token keyword {
[
- | 'goto'
- | 'expr'
- | 'restart'
+ | 'for' |'while' | 'do'
+ | 'if' | 'else'
+ | 'case' | 'default'
+ | 'break' | 'return' | 'continue'
+ | 'goto' | 'expr' | 'restart'
+ | 'OFFSET' | 'ADDRESS' | 'NEXT'
+ ]>>
+}
+
+
+# Part of C grammar.
+
+rule statement_list {
+ [ <labeled_statement> <.eat_terminator> ]*
+}
+
+token labeled_statement {
+ [
+ | <label> <.ws> <statement>
+ | <label>
+ | <statement>
]
+ <.ws>
+ <?MARKER('endstmt')>
}
-token macro_destination {
+token statement {
[
- | 'OFFSET'
- | 'ADDRESS'
- | 'NEXT'
+ | <c_macro>
+ | <statement_control>
+ | <blockoid>
+ | <EXPR>
]
+ <.ws>
+ <?MARKER('endstmt')>
}
-token identifier {
- <.ident>
+token label {
+ [
+ | 'case' <.ws> [ <integer> | <identifier> ] ':'
+ | 'default:'
+ | <identifier> ':'
+ ]
}
-# ws handles whitespace, pod and perl and C comments
-token ws {
+proto rule statement_control { <...> }
+
+rule statement_control:sym<if> {
+ <sym> '(' <EXPR> ')'
+ <then=.statement_or_block>
+ [ 'else' <else=.statement_or_block> ]?
+}
+
+rule statement_control:sym<while> {
+ <sym> '(' <condition=.EXPR> ')'
+ <statement_list=.statement_or_block>
+}
+
+rule statement_control:sym<for> {
+ <sym> '(' <init=.EXPR>? ';' <test=.EXPR>? ';' <step=.EXPR>? ')'
+ <statement_list=.statement_or_block>
+}
+
+rule statement_control:sym<do-while> {
+ 'do' <blockoid> 'while' '(' <condition=.EXPR> ')'
+}
+
+# Not real "C" switch. Just close enough
+rule statement_control:sym<switch> {
+ <sym> '(' <test=.EXPR> ')' '{'
+ <statement_list>
+ '}'
+}
+
+rule statement_control:sym<break> { <sym> }
+rule statement_control:sym<continue> { <sym> }
+
+token statement_or_block {
+ | <blockoid>
+ | <labeled_statement> <.eat_terminator>
+}
+
+# HACK to support for INT_FMT "\n"
+token term:sym<concatenate_strings> { # Long-long name as LTM workaround
+ <identifier> \s+ <quote>
+}
+
+token term:sym<call> {
+ <identifier> <.ws> '(' <arglist> ')'
+}
+
+token term:sym<int> { <integer> ('u'|'U'|'l'|'L')* }
+token term:sym<str> { <quote> }
+token term:sym<float_constant_long> { # longer to work-around lack of LTM
+ [
+ | \d+ '.' \d*
+ | \d* '.' \d+
+ ]
+}
+
+token term:sym<reg> {
+ '$' $<num>=<integer> # Up to nine params.
+}
+
+token term:sym<macro> { <op_macro> }
+
+# Variable name.
+token term:sym<identifier> {
+ <identifier> <!before <ws> '('>
+}
+
+# Assignment and other operations.
+# Basically, we are cheating using "pirop" to store original op.
+token infix:sym<=> { <sym> <O('%assignment :pirop<=>')> }
+token infix:sym<|=> { <sym> <O('%assignment :pirop<|=>')> }
+token infix:sym<&=> { <sym> <O('%assignment :pirop<&=>')> }
+token infix:sym<^=> { <sym> <O('%assignment :pirop<^=>')> }
+
+token infix:sym<+=> { <sym> <O('%assignment :pirop<+=>')> }
+token infix:sym<-=> { <sym> <O('%assignment :pirop<-=>')> }
+token infix:sym<*=> { <sym> <O('%assignment :pirop<*=>')> }
+token infix:sym</=> { <sym> <O('%assignment :pirop</=>')> }
+
+token infix:sym«>>=» { <sym> <O('%assignment :pirop<shr_assign>')> }
+token infix:sym«<<=» { <sym> <O('%assignment :pirop<shl_assign>')> }
+
+token infix:sym<,> { <sym> <O('%comma :pirop<,>')> }
+
+token infix:sym<*> { <sym> <O('%multiplicative :pirop<*>')> }
+token infix:sym</> { <sym> <O('%multiplicative :pirop</>')> }
+token infix:sym<%> { <sym> <O('%multiplicative :pirop<%>')> }
+
+token infix:sym<+> { <sym> <O('%additive :pirop<+>')> }
+token infix:sym<-> { <sym> <!before '>' > <O('%additive :pirop<->')> }
+
+token infix:sym«==» { <sym> <O('%relational :pirop<==>')> }
+token infix:sym«!=» { <sym> <O('%relational :pirop<!=>')> }
+token infix:sym«<=» { <sym> <O('%relational :pirop<le>')> }
+token infix:sym«>=» { <sym> <O('%relational :pirop<ge>')> }
+token infix:sym«<» { <sym> <O('%relational :pirop<lt>')> }
+token infix:sym«>» { <sym> <O('%relational :pirop<gt>')> }
+
+token infix:sym<&> { <sym> <O('%tight_and :pirop<&>')> }
+token infix:sym<^> { <sym> <O('%tight_and :pirop<^>')> } # XXX Check precedence
+token infix:sym<|> { <sym> <O('%tight_or :pirop<|>')> }
+
+token infix:sym<&&> { <sym> <O('%tight_and :pirop<&&>')> }
+token infix:sym<||> { <sym> <O('%tight_or :pirop<||>')> }
+
+token infix:sym«<<» { <sym> <O('%multiplicative :pirop<shl>')> }
+token infix:sym«>>» { <sym> <O('%multiplicative :pirop<shr>')> }
+
+token infix:sym<?:> {
+ '?'
+ <.ws>
+ <EXPR('i=')>
+ ':'
+ <O('%conditional, :reducecheck<ternary>')>
+}
+
+token postcircumfix:sym<[ ]> {
+ '[' <.ws> <EXPR> ']'
+ <O('%methodop')>
+}
+
+#token postfix:sym«->» { <sym> <identifier> <O('%methodop :pirop<arrow>')> }
+#token postfix:sym«.» { <sym> <identifier> <O('%methodop :pirop<dotty>')> }
+token infix:sym«->» { <sym> <O('%dotty :pirop<arrow>')> }
+token infix:sym«.» { <sym> <O('%dotty :pirop<dotty>')> }
+
+# XXX Check precedence
+token postfix:sym<--> { <sym> <O('%autoincrement :pirop<-->')> }
+token postfix:sym<++> { <sym> <O('%autoincrement :pirop<++>')> }
+
+rule arglist {
+ | <arg> ** ','
+ | <?>
+}
+
+token arg {
+ | <EXPR('i=')>
+ | <type_declarator>
+}
+
+# Casting. TODO Figure out precedence.
+token prefix:sym<( )> {
+ '(' <type_declarator> ')'
+ <O('%casting')>
+}
+
+token circumfix:sym<( )> {
+ '(' <.ws> <EXPR> ')'
+ <O('%methodop')> # XXX Check precedence
+}
+
+token prefix:sym<+> { <sym> <![+]> <O('%symbolic_unary :pirop<+>')> }
+token prefix:sym<-> { <sym> <![>\-]> <O('%symbolic_unary :pirop<->')> }
+token prefix:sym<!> { <sym> <O('%symbolic_unary :pirop<!>')> }
+token prefix:sym<|> { <sym> <O('%symbolic_unary :pirop<|>')> }
+token prefix:sym<&> { <sym> <O('%symbolic_unary :pirop<&>')> }
+token prefix:sym<*> { <sym> <O('%symbolic_unary :pirop<*>')> }
+token prefix:sym<~> { <sym> <O('%symbolic_unary :pirop<~>')> }
+
+token prefix:sym<return> { <sym> <O('%symbolic_unary :pirop<return>')> }
+
+rule blockoid {
+ '{' <mixed_content> '}'
+}
+
+rule mixed_content {
+ <declarator>*
+ <statement_list>
+}
+
+# Simplified parsing of declarator
+rule declarator {
+ <type_declarator=.pointerless_type> [ <declarator_name> ** ',' ] ';'
+}
+
+rule declarator_name {
+ <pointer>* <variable=.ident> [ '[' <array_size=.integer> ']' ]? [ '=' <EXPR('i=')> ]?
+}
+
+rule pointer { <star> 'const'? }
+token star { '*' }
+
+rule pointerless_type {
+ 'struct'? 'const'? <identifier>
+}
+
+rule type_declarator {
+ 'struct'? 'const'? <identifier> <pointer>*
+}
+
+token eat_terminator {
+ | ';'
+ | <?MARKED('endstmt')>
+ | $
+}
+
+token pod_ws {
[
| \s+
| '#' \N*
| ^^ '=' .*? \n '=cut'
+ ]*
+}
+
+# ws handles whitespace and C comments
+token ws {
+ [
+ | \s+
| '/*' .*? '*/'
]*
}
+INIT {
+ Ops::Compiler::Grammar.O(':prec<z=>, :assoc<unary>', '%methodop');
+ Ops::Compiler::Grammar.O(':prec<y=>, :assoc<left>', '%dotty');
+ Ops::Compiler::Grammar.O(':prec<x=>, :assoc<unary>', '%autoincrement');
+ Ops::Compiler::Grammar.O(':prec<w=>, :assoc<unary>', '%casting');
+ Ops::Compiler::Grammar.O(':prec<v=>, :assoc<unary>', '%symbolic_unary');
+ Ops::Compiler::Grammar.O(':prec<u=>, :assoc<left>', '%multiplicative');
+ Ops::Compiler::Grammar.O(':prec<t=>, :assoc<left>', '%additive');
+ Ops::Compiler::Grammar.O(':prec<r=>, :assoc<left>', '%concatenation');
+ Ops::Compiler::Grammar.O(':prec<m=>, :assoc<left>', '%relational');
+ Ops::Compiler::Grammar.O(':prec<l=>, :assoc<left>', '%tight_and');
+ Ops::Compiler::Grammar.O(':prec<k=>, :assoc<left>', '%tight_or');
+ Ops::Compiler::Grammar.O(':prec<j=>, :assoc<right>', '%conditional');
+ Ops::Compiler::Grammar.O(':prec<i=>, :assoc<right>', '%assignment');
+ Ops::Compiler::Grammar.O(':prec<g=>, :assoc<list>, :nextterm<nulltermish>', '%comma');
+ Ops::Compiler::Grammar.O(':prec<f=>, :assoc<list>', '%list_infix');
+ Ops::Compiler::Grammar.O(':prec<e=>, :assoc<unary>', '%list_prefix');
+}
+
# vim: expandtab shiftwidth=4 ft=perl6:
View
391 compilers/opsc/src/Ops/Op.pm
@@ -188,7 +188,9 @@ Sets/gets the op's code body.
method body() {
my $res := '';
for @(self) -> $part {
- $res := $res ~ $part<inline>;
+ if pir::defined($part) {
+ $res := $res ~ $part<inline>;
+ }
}
$res;
}
@@ -281,66 +283,354 @@ method >> >>> to C<VTABLE_I<method>>.
method get_body( $trans ) {
- my @body := list();
+ my %context := hash(
+ trans => $trans,
+ level => 0,
+ );
#work through the op_body tree
- for @(self) {
- my $chunk := self.process_body_chunk($trans, $_);
- #pir::say('# chunk ' ~ $chunk);
- @body.push($chunk);
+ self.join_children(self, %context);
+}
+
+# Recursively process body chunks returning string.
+our multi method to_c(PAST::Val $val, %c) {
+ $val.value;
+}
+
+our multi method to_c(PAST::Var $var, %c) {
+ if ($var.isdecl) {
+ my $res := $var.vivibase ~ ' ' ~ $var<pointer> ~ ' ' ~ $var.name;
+
+ if my $arr := $var<array_size> {
+ $res := $res ~ '[' ~ $arr ~ ']';
+ }
+
+ if my $expr := $var.viviself {
+ $res := $res ~ ' = ' ~ self.to_c($expr, %c);
+ }
+ $res;
+ }
+ elsif $var.scope eq 'keyed' {
+ self.to_c($var[0], %c) ~ '[' ~ self.to_c($var[1], %c) ~ ']';
+ }
+ elsif $var.scope eq 'register' {
+ my $n := +$var.name;
+ %c<trans>.access_arg( self.arg_type($n - 1), $n);
}
+ else {
+ # Just ordinary variable
+ $var.name;
+ }
+}
+
+our %PIROP_MAPPING := hash(
+ :shr('>>'),
+ :shl('<<'),
+
+ :shr_assign('>>='),
+ :shl_assign('<<='),
+
+ :le('<='),
+ :ge('>='),
+ :lt('<'),
+ :gt('>'),
- join('', |@body);
+ :arrow('->'),
+ :dotty('.'),
+);
+
+our method to_c:pasttype<inline> (PAST::Op $chunk, %c) {
+ return $chunk.inline;
}
-# Recursively process body chunks returning string.
+our method to_c:pasttype<macro> (PAST::Op $chunk, %c) {
+ my $name := $chunk.name;
+ my $children := self.join_children($chunk, %c);
+
+ my $trans := %c<trans>;
+
+ #pir::say('children ' ~ $children);
+ my $ret := Q:PIR<
+ $P0 = find_lex '$trans'
+ $P1 = find_lex '$name'
+ $S0 = $P1
+ $P1 = find_lex '$children'
+ %r = $P0.$S0($P1)
+ >;
+ #pir::say('RET ' ~ $ret);
+ return $ret;
+}
+
+our method to_c:pasttype<macro_define> (PAST::Op $chunk, %c) {
+ my @res;
+ @res.push('#define ');
+ #name of macro
+ @res.push($chunk[0]);
+
+ @res.push(self.to_c($chunk<macro_args>, %c)) if $chunk<macro_args>;
+ @res.push(self.to_c($chunk<body>, %c)) if $chunk<body>;
+
+ @res.join('');
+}
+
+
+our method to_c:pasttype<macro_if> (PAST::Op $chunk, %c) {
+ my @res;
+
+ @res.push('#if ');
+ # #if isn't parsed semantically yet.
+ @res.push($chunk[0]);
+ #@res.push(self.to_c($trans, $chunk[0]));
+ @res.push("\n");
+
+ # 'then'
+ @res.push(self.to_c($chunk[1], %c));
+
+ # 'else'
+ @res.push("\n#else\n" ~ self.to_c($chunk[2], %c)) if $chunk[2];
-our multi method process_body_chunk($trans, PAST::Var $chunk) {
- my $n := +$chunk.name;
- $trans.access_arg( self.arg_type($n - 1), $n);
+ @res.push("\n#endif\n");
+
+ @res.join('');
+}
+our method to_c:pasttype<call> (PAST::Op $chunk, %c) {
+ join('',
+ $chunk.name,
+ '(',
+ # Handle args.
+ self.join_children($chunk, %c, ', '),
+ ')',
+ );
}
-our multi method process_body_chunk($trans, PAST::Op $chunk) {
- my $type := $chunk.pasttype;
- #say('OP ' ~ $type);
- if $type eq 'inline' {
- #_dumper($chunk);
- #pir::say('RET ' ~ $chunk<inline>);
- return $chunk.inline;
+our method to_c:pasttype<if> (PAST::Op $chunk, %c) {
+ my @res;
+
+ if ($chunk<ternary>) {
+ @res.push(self.to_c($chunk[0], %c));
+ @res.push(" ? ");
+ # 'then'
+ @res.push(self.to_c($chunk[1], %c));
+ # 'else'
+ @res.push(" : ");
+ @res.push(self.to_c($chunk[2], %c));
}
- elsif $type eq 'call' {
- my $name := $chunk.name;
- #say('NAME '~$name ~ ' ' ~ $is_next);
- if $name eq 'OPSIZE' {
- #say('is_next');
- return ~self.size;
+ else {
+ @res.push('if (');
+ @res.push(self.to_c($chunk[0], %c));
+ @res.push(") ");
+
+ # 'then'
+ # single statement. Make it pretty.
+
+ @res.push(self.to_c($chunk[1], %c));
+
+ # 'else'
+ if $chunk[2] {
+ @res.push("\n");
+ @res.push(indent(%c));
+ @res.push("else ");
+ @res.push(self.to_c($chunk[2], %c));
}
+ }
+
+ @res.join('');
+}
+
+our method to_c:pasttype<while> (PAST::Op $chunk, %c) {
+ join('',
+ 'while (',
+ self.to_c($chunk[0], %c),
+ ') ',
+ self.to_c($chunk[1], %c),
+ );
+}
+
+our method to_c:pasttype<do-while> (PAST::Op $chunk, %c) {
+ join('',
+ 'do ',
+ self.to_c($chunk[0], %c),
+ ' while (',
+ self.to_c($chunk[1], %c),
+ ');',
+ );
+}
+
+our method to_c:pasttype<for> (PAST::Op $chunk, %c) {
+ join('',
+ 'for (',
+ $chunk[0] ?? self.to_c($chunk[0], %c) !! '',
+ '; ',
+ $chunk[1] ?? self.to_c($chunk[1], %c) !! '',
+ '; ',
+ $chunk[2] ?? self.to_c($chunk[2], %c) !! '',
+ ') ',
+ self.to_c($chunk[3], %c),
+ );
+}
+
+our method to_c:pasttype<switch> (PAST::Op $chunk, %c) {
+ join('',
+ 'switch (',
+ self.to_c($chunk[0], %c),
+ ') {',
+ "\n",
+ self.to_c($chunk[1], %c),
+ "\n",
+ indent(%c),
+ "}",
+ );
+}
+
+our method to_c:pasttype<undef> (PAST::Op $chunk, %c) {
+ my $pirop := $chunk.pirop;
- my @children := list();
- for @($chunk) {
- @children.push(self.process_body_chunk($trans, $_));
+ if $pirop {
+ # Some infix stuff
+ if $pirop eq ',' {
+ self.join_children($chunk, %c, ', ');
}
- my $children := join('', |@children);
-
- #pir::say('children ' ~ $children);
- my $ret := Q:PIR<
- $P0 = find_lex '$trans'
- $P1 = find_lex '$name'
- $S0 = $P1
- $P1 = find_lex '$children'
- %r = $P0.$S0($P1)
- >;
- #pir::say('RET ' ~ $ret);
- return $ret;
+ elsif $pirop eq '=' {
+ self.to_c($chunk[0], %c)
+ ~ ' = '
+ ~ self.to_c($chunk[1], %c)
+ }
+ elsif ($pirop eq 'arrow') || ($pirop eq 'dotty') {
+ self.to_c($chunk[0], %c)
+ ~ %PIROP_MAPPING{$pirop}
+ ~ self.to_c($chunk[1], %c)
+ }
+ elsif $chunk.name ~~ / infix / {
+ '('
+ ~ self.to_c($chunk[0], %c)
+ ~ ' ' ~ (%PIROP_MAPPING{$pirop} // $pirop) ~ ' '
+ ~ self.to_c($chunk[1], %c)
+ ~ ')';
+ }
+ elsif $chunk.name ~~ / prefix / {
+ '('
+ ~ (%PIROP_MAPPING{$pirop} // $pirop)
+ ~ self.to_c($chunk[0], %c)
+ ~ ')';
+ }
+ elsif $chunk.name ~~ / postfix / {
+ '('
+ ~ self.to_c($chunk[0], %c)
+ ~ (%PIROP_MAPPING{$pirop} // $pirop)
+ ~ ')';
+ }
+ else {
+ _dumper($chunk);
+ pir::die("Unhandled chunk for pirop");
+ }
+ }
+ elsif $chunk.returns {
+ # Handle "cast"
+ join('',
+ '(',
+ $chunk.returns,
+ ')',
+ self.to_c($chunk[0], %c),
+ );
+ }
+ elsif $chunk<control> {
+ $chunk<control>;
+ }
+ elsif $chunk<label> {
+ # Do nothing. Empty label for statement.
+ "";
+ }
+ else {
+ _dumper($chunk);
+ pir::die("Unhandled chunk");
+ }
+}
+
+our multi method to_c(PAST::Op $chunk, %c) {
+ my @res;
+
+ @res.push($chunk<label> ~ "\n" ~ indent(%c)) if $chunk<label>;
+
+ my $type := $chunk.pasttype // 'undef';
+ my $sub := pir::find_sub_not_null__ps('to_c:pasttype<' ~ $type ~ '>');
+
+ @res.push('(') if $chunk<wrap>;
+ @res.push($sub(self, $chunk, %c));
+ @res.push(')') if $chunk<wrap>;
+
+ @res.join('');
+}
+
+our multi method to_c(PAST::Stmts $chunk, %c) {
+ %c<level>++ unless $chunk[0] ~~ PAST::Block;
+
+ my @res;
+ for @($chunk) {
+ @res.push(indent($_, %c)) unless $_ ~~ PAST::Block;
+
+ @res.push(self.to_c($_, %c));
+ @res.push(";") if need_semicolon($_);
+ @res.push("\n");
}
+ %c<level>-- unless $chunk[0] ~~ PAST::Block;
+
+ @res.join('');
}
-our multi method process_body_chunk($trans, PAST::Stmts $chunk) {
- my @children := list();
+our multi method to_c(PAST::Block $chunk, %c) {
+ # Put newline after variable declarations.
+ my $need_space := need_space($chunk[0]);
+
+ my @res;
+ @res.push(indent($chunk, %c) ~ $chunk<label> ~ "\n" ~ indent(%c)) if $chunk<label>;
+
+ %c<level>++;
+
+ @res.push("\{\n");
+
for @($chunk) {
- @children.push(self.process_body_chunk($trans, $_));
+ if $need_space && !need_space($_) {
+ # Hack. If this $chunk doesn't need semicolon it will put newline before
+ @res.push("\n");
+ $need_space := 0;
+ }
+
+ @res.push(indent($_, %c));
+ @res.push(self.to_c($_, %c));
+ @res.push(need_semicolon($_) ?? ";" !! "\n");
+ @res.push("\n");
}
- join('', |@children);
+
+ %c<level>--;
+ @res.push(indent(%c));
+ @res.push("}");
+
+ @res.join('');
+}
+
+sub need_space($past) {
+ ($past ~~ PAST::Var) && $past.isdecl;
+}
+
+sub need_semicolon($past) {
+ return 0 if $past ~~ PAST::Block;
+ return 1 unless $past ~~ PAST::Op;
+
+ my $pasttype := $past.pasttype;
+ return 1 unless $pasttype;
+ return 0 if $pasttype eq 'if';
+ return 0 if $pasttype eq 'for';
+ return 0 if $pasttype eq 'while';
+ return 0 if $pasttype eq 'do-while';
+ return 0 if $pasttype eq 'switch';
+
+ return 1;
+}
+
+
+# Stub!
+our multi method to_c(String $str, %c) {
+ $str;
}
=begin
@@ -353,9 +643,22 @@ the op itself as one argument.
=end
method size() {
- return pir::does__IPs(self.arg_types, 'array') ?? +self.arg_types + 1 !! 2;
+ return pir::does__IPs(self.args, 'array') ?? +self.args + 1 !! 2;
+}
+
+method join_children (PAST::Node $node, %c, $joiner?) {
+ @($node).map(-> $_ { self.to_c($_, %c) }).join($joiner // '');
+}
+
+our multi sub indent($chunk, %c) {
+ pir::repeat(' ', %c<level> * 4 - ($chunk<label> ?? 2 !! 0));
}
+our multi sub indent(%c) {
+ pir::repeat(' ', %c<level> * 4);
+}
+
+
=begin
=back
View
2  compilers/opsc/src/Ops/Trans/C.pm
@@ -56,7 +56,7 @@ method prepare_ops($emitter, $ops_file) {
@op_func_table.push(sprintf( " %-50s /* %6ld */\n", "$func_name,", $index ));
- my $body := join('', $definition, ' {', "\n", $src, '}', "\n\n");
+ my $body := join('', $definition, ' ', $src, "\n\n");
@op_funcs.push($body);
@op_protos.push($prototype);
$index++;
View
17 config/auto/coverage.pm
@@ -9,15 +9,14 @@ config/auto/coverage- Check whether coverage analysis tools are present
Coverage analysis is the measurement of the extent to which a program's source
code is exercised by its tests.
-In Parrot, we can perform coverage analysis
-on our Parrot source code (well, at least on F<.c> and F<.pmc> files) and on
-the Perl 5 components used in our tools.
-
-To conduct such analysis, we need
-the C coverage utility F<gcov> and two utilities, F<cover> and F<gcov2perl>,
-which are included in the Devel-Cover distribution from CPAN. (Paul
-Johnson++). This configuration step determines whether those utilities are
-present.
+In Parrot, we can perform coverage analysis on our Parrot source code (well,
+at least on F<.c> and F<.pmc> files) and on the Perl 5 components used in our
+tools.
+
+To conduct such analysis, we need the C coverage utility F<gcov> and two
+utilities, F<cover> and F<gcov2perl>, which are included in the Devel-Cover
+distribution from CPAN. (Paul Johnson++). This configuration step determines
+whether those utilities are present.
=cut
View
66 config/auto/infnan.pm
@@ -0,0 +1,66 @@
+# Copyright (C) 2010, Parrot Foundation.
+# $Id$
+
+=head1 NAME
+
+config/auto/infnan.pm - detect INFINITY and NAN
+
+=head1 DESCRIPTION
+
+Determining if the system has INFINITY, NAN, isinf, and isnan defined in headers.
+
+=cut
+
+package auto::infnan;
+
+use strict;
+use warnings;
+
+use base qw(Parrot::Configure::Step);
+
+use Parrot::Configure::Utils ':auto';
+
+sub _init {
+ my $self = shift;
+ my %data;
+ $data{description} = q{Is standard C Inf/NaN handling present};
+ $data{result} = q{};
+ return \%data;
+}
+
+sub runstep {
+ my ( $self, $conf ) = @_;
+
+ my $infnan = 0;
+
+ $conf->cc_gen('config/auto/infnan/test_c.in');
+ eval { $conf->cc_build(); };
+ if (!$@) {
+ my $output = eval { $conf->cc_run() };
+ if (!$@ && $output =~ /OK/) {
+ $infnan = 1;
+ }
+ }
+ $conf->cc_clean();
+
+ if ($infnan) {
+ $conf->data->set( HAS_INF_NAN => 1 );
+ $self->set_result('yes');
+ }
+ else {
+ $conf->data->set( HAS_INF_NAN => 0 );
+ $self->set_result('no');
+ }
+
+ return 1;
+}
+
+1;
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
+
View
26 config/auto/infnan/test_c.in
@@ -0,0 +1,26 @@
+/*
+Copyright (C) 2010, Parrot Foundation.
+$Id$
+
+seeing if INFINITY and NAN are defined
+
+*/
+
+#include <stdlib.h>
+#include <stdio.h>
+#include <math.h>
+
+int
+main(int argc, char **argv) {
+ double inf = INFINITY;
+ double nan = NAN;
+ printf("OK: %d %d\n", isinf(inf), isnan(nan));
+ return EXIT_SUCCESS;
+}
+
+/*
+ * Local variables:
+ * c-file-style: "parrot"
+ * End:
+ * vim: expandtab shiftwidth=4 cinoptions='\:2=2' :
+ */
View
225 config/auto/sizes.pm
@@ -31,70 +31,75 @@ sub _init {
sub runstep {
my ( $self, $conf ) = @_;
- $conf->cc_gen('config/auto/sizes/test_c.in');
- $conf->cc_build();
- my %results = eval $conf->cc_run();
- $conf->cc_clean();
-
- for ( keys %results ) {
- $conf->data->set( $_ => $results{$_} );
- }
+ my %types = (
+ intval => $conf->data->get('iv'),
+ numval => $conf->data->get('nv'),
+ opcode => $conf->data->get('opcode_t'),
+ short => 'short',
+ int => 'int',
+ long => 'long',
+ longlong => 'long long',
+ ptr => 'void *',
+ float => 'float',
+ double => 'double',
+ longdouble => 'long double',
+ );
- _handle_intval_ptrsize_discrepancy(\%results);
+ my %sizes = map {
+ $_, test_size($conf, $types{$_})
+ } keys %types;
- # set fixed sized types
- _set_int2($conf, \%results);
+ for ( keys %sizes ) {
+ $conf->data->set( $_ . 'size' => $sizes{$_} );
+ }
- _set_int4($conf, \%results);
+ _handle_intval_ptrsize_discrepancy(\%sizes);
+ _handle_longlong($conf, \%sizes);
- _set_float4($conf, \%results);
+ # probe for 64-bit integer-types
+ foreach my $type ('int64_t', '__int64') {
+ my $size = test_size($conf, $type);
+ if ($size) {
+ $types{int64} = $type;
+ $sizes{int64} = $size;
+ last;
+ }
+ }
- _set_float8($conf, \%results);
+ # set fixed sized types
+ _set_int2($conf, \%types, \%sizes);
- my %hugeintval;
- my $intval = $conf->data->get('iv');
- my $intvalsize = $conf->data->get('intvalsize');
+ _set_int4($conf, \%types, \%sizes);
- # Get HUGEINTVAL, note that we prefer standard types
- foreach my $type ( 'long', 'int', 'long long', '__int64' ) {
+ _set_int8($conf, \%types, \%sizes);
- $conf->data->set( int8_t => $type );
- eval {
- $conf->cc_gen('config/auto/sizes/test2_c.in');
- $conf->cc_build();
- %hugeintval = eval $conf->cc_run();
- $conf->cc_clean();
- };
+ _set_float4($conf, \%types, \%sizes);
- # clear int8_t on error
- if ( $@ || !exists $hugeintval{hugeintval} ) {
- $conf->data->set( int8_t => undef );
- next;
- }
+ _set_float8($conf, \%types, \%sizes);
- if ( $hugeintval{hugeintvalsize} > $intvalsize ) {
+ # get HUGEINTVAL
+ my $hiv = do {
+ my @t = ('long', 'int', 'longlong', 'int64', 'invtal');
+ my $i = maxind( @sizes{grep exists $sizes{$_}, @t} );
+ $t[$i];
+ };
- # We found something bigger than intval.
- $conf->data->set(%hugeintval);
- last;
- }
- }
- _handle_hugeintvalsize(
- $conf,
- {
- hugeintval => \%hugeintval,
- intval => $intval,
- intvalsize => $intvalsize,
- },
+ $conf->data->set(
+ hugeintval => $types{$hiv},
+ hugeintvalsize => $sizes{$hiv},
);
- $conf->cc_clean();
-
- #get HUGEFLOATVAL
- my $size = _probe_for_hugefloatval( $conf );
- _set_hugefloatval( $conf, $size );
+ # get HUGEFLOATVAL
+ my $hfv = do {
+ my @t = ('float', 'double', 'longdouble', 'numval');
+ my $i = maxind( @sizes{@t} );
+ $t[$i];
+ };
- $conf->cc_clean();
+ $conf->data->set(
+ hugefloatval => $types{$hfv},
+ hugefloatvalsize => $sizes{$hfv},
+ );
_set_intvalmaxmin($conf);
@@ -105,9 +110,27 @@ sub runstep {
#################### INTERNAL SUBROUTINES ####################
+sub test_size {
+ my ($conf, $type) = @_;
+
+ $conf->data->set( TEMP_type => $type );
+ $conf->cc_gen('config/auto/sizes/test_c.in');
+ eval { $conf->cc_build() };
+ my $ret = $@ ? 0 : eval $conf->cc_run();
+ $conf->cc_clean();
+
+ return $ret;
+}
+
+sub maxind {
+ my $i = 0;
+ $_[$_] <= $_[$i] or $i = $_ for 0..$#_;
+ return $i;
+}
+
sub _handle_intval_ptrsize_discrepancy {
- my $resultsref = shift;
- if ( $resultsref->{ptrsize} != $resultsref->{intvalsize} ) {
+ my $sizesref = shift;
+ if ( $sizesref->{ptr} != $sizesref->{intval} ) {
print <<"END";
Hmm, I see your chosen INTVAL isn't the same size as your pointers. Parrot
@@ -116,9 +139,14 @@ END
}
}
+sub _handle_longlong {
+ my ($conf, $sizesref) = @_;
+ $conf->data->set( HAS_LONGLONG => !!($sizesref->{longlong} > 0) );
+}
+
sub _set_int2 {
- my ($conf, $resultsref) = @_;
- if ( $resultsref->{shortsize} == 2 ) {
+ my ($conf, $typesref, $sizesref) = @_;
+ if ( $sizesref->{short} == 2 ) {
$conf->data->set( int2_t => 'short' );
}
else {
@@ -132,29 +160,45 @@ END
}
sub _set_int4 {
- my ($conf, $resultsref) = @_;
- if ( $resultsref->{shortsize} == 4 ) {
- $conf->data->set( int4_t => 'short' );
- }
- elsif ( $resultsref->{intsize} == 4 ) {
- $conf->data->set( int4_t => 'int' );
- }
- elsif ( $resultsref->{longsize} == 4 ) {
- $conf->data->set( int4_t => 'long' );
+ my ($conf, $typesref, $sizesref) = @_;
+ foreach my $type (qw[ short int long ]) {
+ if ( $sizesref->{$type} == 4 ) {
+ $conf->data->set( int4_t => $typesref->{$type} );
+ return;
+ }
}
- else {
- $conf->data->set( int4_t => 'int' );
- print <<'END';
+
+ $conf->data->set( int4_t => 'int' );
+ print <<'END';
Can't find a int type with size 4, conversion ops might fail!
END
+}
+
+sub _set_int8 {
+ my ($conf, $typesref, $sizesref) = @_;
+ foreach my $type (qw[ int long longlong int64 ]) {
+ if ( $sizesref->{$type} == 8 ) {
+ $conf->data->set(
+ int8_t => $typesref->{$type},
+ HAS_INT64 => 1,
+ );
+ return;
+ }
}
+
+ $conf->data->set( HAS_INT64 => 0 );
+ print <<'END';
+
+Can't find an int type with size 8, 64-bit support dissabled.
+
+END
}
sub _set_float4 {
- my ($conf, $resultsref) = @_;
- if ( $resultsref->{floatsize} == 4 ) {