GitHub/pbot
3
0
Fork 0
mirror of https://github.com/pragma-/pbot.git synced 2024-11-26 22:09:26 +01:00
Code Issues Projects Releases Wiki Activity

Significantly refactor compiler_vm module

Browse Source 
The compiler_vm module has been significantly refactored into distinct
modules in order to better facilitate the addition of other languages
and compilers.

Currently there is support for C89, C99 and C11 using gcc, as well as
support for Perl.

This is an initial work-in-progress commit and there are still some minor
rough edges to polish up.
This commit is contained in:
Pragmatic Software 2015-01-14 21:51:17 -08:00
parent 659e61f1fb
commit b6b90ffa49
11 changed files with 1648 additions and 1369 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1248
modules/compiler_vm/compiler_vm_client.pl
View File

File diff suppressed because it is too large Load Diff

199
modules/compiler_vm/compiler_vm_server.pl
View File

@ -1,34 +1,33 @@
#!/usr/bin/perl
#!/usr/bin/env perl
use warnings;
use strict;
use File::Basename;
my $USE_LOCAL = defined $ENV{'CC_LOCAL'};
my %languages = (
'C89' => {
'cmdline' => 'gcc $file $args -o prog -ggdb -g3',
'args' => '-Wextra -Wall -Wno-unused -std=gnu89 -lm -Wfloat-equal -Wshadow -Wfatal-errors',
'file' => 'prog.c',
},
'C++' => {
'cmdline' => 'g++ $file $args -o prog -ggdb',
'args' => '-lm',
'file' => 'prog.cpp',
},
'C99' => {
'cmdline' => 'gcc $file $args -o prog -ggdb -g3',
'args' => '-Wextra -Wall -Wno-unused -pedantic -Wfloat-equal -Wshadow -std=c99 -lm -Wfatal-errors',
'file' => 'prog.c',
},
'C11' => {
'cmdline' => 'gcc $file $args -o prog -ggdb -g3',
'args' => '-Wextra -Wall -Wno-unused -pedantic -Wfloat-equal -Wshadow -std=c11 -lm -Wfatal-errors',
'file' => 'prog.c',
},
);
# uncomment the following if installed to the virtual machine
# use constant MOD_DIR => '/usr/local/share/compiler_vm/languages';
sub runserver {
use constant MOD_DIR => 'languages/server';
use lib MOD_DIR;
my %languages;
sub load_modules {
my @files = glob MOD_DIR . "/*.pm";
foreach my $mod (@files){
print "Loading module $mod\n";
my $filename = basename($mod);
require $filename;
$filename =~ s/\.pm$//;
$languages{$filename} = 1;
}
}
sub run_server {
my ($input, $output, $heartbeat);
if(not defined $USE_LOCAL or $USE_LOCAL == 0) {
@ -42,8 +41,10 @@ sub runserver {
my $date;
my $lang;
my $sourcefile;
my $execfile;
my $code;
my $user_args;
my $cmdline;
my $user_input;
print "Waiting for input...\n";
@ -62,14 +63,12 @@ sub runserver {
print "Attempting compile [$lang] ...\n";
my $result = interpret($lang, $code, $user_args, $user_input, $date);
my $result = interpret($lang, $sourcefile, $execfile, $code, $cmdline, $user_input, $date);
print "Done compiling; result: [$result]\n";
print $output "result:$result\n";
print $output "result:end\n";
#system("rm prog");
if(not defined $USE_LOCAL or $USE_LOCAL == 0) {
print "input: ";
next;
@ -80,18 +79,22 @@ sub runserver {
if($line =~ m/^compile:\s*(.*)/) {
my $options = $1;
$user_args = undef;
$cmdline = undef;
$user_input = undef;
$lang = undef;
$sourcefile = undef;
$execfile = undef;
($lang, $user_args, $user_input, $date) = split /:/, $options;
($lang, $sourcefile, $execfile, $cmdline, $user_input, $date) = split /:/, $options;
$code = "";
$lang = "C11" if not defined $lang;
$user_args = "" if not defined $user_args;
$sourcefile = "/dev/null" if not defined $sourcefile;
$execfile = "/dev/null" if not defined $execfile;
$lang = "unknown" if not defined $lang;
$cmdline = "echo No cmdline specified!" if not defined $cmdline;
$user_input = "" if not defined $user_input;
print "Setting lang [$lang]; [$user_args]; [$user_input]; [$date]\n";
print "Setting lang [$lang]; [$sourcefile]; [$cmdline]; [$user_input]; [$date]\n";
next;
}
@ -110,128 +113,34 @@ sub runserver {
}
sub interpret {
my ($lang, $code, $user_args, $user_input, $date) = @_;
my ($lang, $sourcefile, $execfile, $code, $cmdline, $input, $date) = @_;
print "lang: [$lang], code: [$code], user_args: [$user_args], input: [$user_input], date: [$date]\n";
print "lang: [$lang], sourcefile: [$sourcefile], execfile [$execfile], code: [$code], cmdline: [$cmdline], input: [$input], date: [$date]\n";
$lang = uc $lang;
if(not exists $languages{$lang}) {
return "No support for language '$lang' at this time.\n";
}
$lang = '_default' if not exists $languages{$lang};
system("chmod -R 755 /home/compiler");
open(my $fh, '>', $languages{$lang}{'file'}) or die $!;
print $fh $code . "\n";
close $fh;
my $mod = $lang->new(sourcefile => $sourcefile, execfile => $execfile, code => $code,
cmdline => $cmdline, input => $input, date => $date);
my $cmdline = $languages{$lang}{'cmdline'};
$mod->preprocess;
my $diagnostics_caret;
if($user_args =~ s/\s+-paste//) {
$diagnostics_caret = '-fdiagnostics-show-caret';
} else {
$diagnostics_caret = '-fno-diagnostics-show-caret';
if($cmdline =~ m/-?-version/) {
# cmdline contained version request, so don't postprocess and just return the version output
$mod->{output} =~ s/\s+\(Ubuntu.*-\d+ubuntu\d+\)//;
return $mod->{output};
}
if(length $user_args) {
print "Replacing args with $user_args\n";
my $user_args_quoted = quotemeta($user_args);
$user_args_quoted =~ s/\\ / /g;
$cmdline =~ s/\$args/$user_args_quoted $diagnostics_caret/;
} else {
$cmdline =~ s/\$args/$languages{$lang}{'args'} $diagnostics_caret/;
$mod->postprocess if not $mod->{error};
if (not length $mod->{output}) {
$mod->{output} = "Success (no output).\n" if not $mod->{error};
$mod->{output} = "Success (exit code $mod->{error}).\n" if $mod->{error};
}
$cmdline =~ s/\$file/$languages{$lang}{'file'}/;
print "Executing [$cmdline]\n";
my ($ret, $result) = execute(60, $cmdline);
# print "Got result: ($ret) [$result]\n";
# if exit code was not 0, then there was a problem compiling, such as an error diagnostic
# so return the compiler output
if($ret != 0) {
return $result;
return $mod->{output};
}
if($user_args =~ m/--version/) {
# arg contained --version, so don't compile and just return the version output
$result =~ s/\s+\(Ubuntu.*-\d+ubuntu\d+\)//;
return $result;
}
# no errors compiling, but if $result contains something, it must be a warning message
# so prepend it to the output
my $output = "";
if(length $result) {
$result =~ s/^\s+//;
$result =~ s/\s+$//;
$output = "[$result]\n";
}
print "Executing gdb\n";
my $user_input_quoted = quotemeta $user_input;
$user_input_quoted =~ s/\\"/"'\\"'"/g;
($ret, $result) = execute(60, "bash -c \"date -s \@$date; ulimit -t 1; compiler_watchdog.pl $user_input_quoted > .output\"");
$result = "";
open(FILE, '.output');
while(<FILE>) {
$result .= $_;
last if length $result >= 2048 * 20;
}
close(FILE);
$result =~ s/\s+$//;
# print "Executed prog; got result: ($ret) [$result]\n";
if(not length $result) {
$result = "Success (no output).\n" if $ret == 0;
$result = "Success (exit code $ret).\n" if $ret != 0;
}
return $output . "\n" . $result;
}
sub execute {
my $timeout = shift @_;
my ($cmdline) = @_;
my ($ret, $result);
($ret, $result) = eval {
print "eval\n";
my $result = '';
my $pid = open(my $fh, '-|', "$cmdline 2>&1");
local $SIG{ALRM} = sub { print "Time out\n"; kill 'TERM', $pid; die "$result [Timed-out]\n"; };
alarm($timeout);
while(my $line = <$fh>) {
$result .= $line;
}
close $fh;
my $ret = $? >> 8;
alarm 0;
return ($ret, $result);
};
print "done eval\n";
alarm 0;
if($@ =~ /Timed-out/) {
return (-1, $@);
}
print "[$ret, $result]\n";
return ($ret, $result);
}
runserver;
load_modules;
run_server;

806
modules/compiler_vm/languages/_default.pm Executable file
View File

@ -0,0 +1,806 @@
#!/usr/bin/perl
use warnings;
use strict;
use feature "switch";
no if $] >= 5.018, warnings => "experimental::smartmatch";
package _default;
use IPC::Open2;
use IO::Socket;
use LWP::UserAgent;
use Time::HiRes qw/gettimeofday/;
use Text::Balanced qw/extract_delimited/;
my $EXECUTE_PORT = '3334';
sub new {
my ($class, %conf) = @_;
my $self = bless {}, $class;
$self->{debug} = $conf{debug} // 0;
$self->{nick} = $conf{nick};
$self->{channel} = $conf{channel};
$self->{lang} = $conf{lang};
$self->{code} = $conf{code};
$self->{max_history} = $conf{max_history} // 10000;
$self->{default_options} = '';
$self->{cmdline} = 'echo Hello, world!';
$self->initialize(%conf);
return $self;
}
sub initialize {
my ($self, %conf) = @_;
}
sub pretty_format {
my $self = shift;
return $self->{code};
}
sub preprocess_code {
my $self = shift;
if ($self->{only_show}) {
print "$self->{nick}: $self->{code}\n";
exit;
}
unless($self->{got_run} and $self->{copy_code}) {
open FILE, ">> log.txt";
print FILE localtime() . "\n";
print FILE "$self->{nick} $self->{channel}: " . $self->{cmdline_options} . "$self->{code}\n";
close FILE;
}
}
sub postprocess_output {
my $self = shift;
unless($self->{got_run} and $self->{copy_code}) {
open FILE, ">> log.txt";
print FILE "------------------------------------------------------------------------\n";
print FILE localtime() . "\n";
print FILE "$self->{output}\n";
close FILE;
}
}
sub show_output {
my $self = shift;
my $output = $self->{output};
unless($self->{got_run} and $self->{copy_code}) {
open FILE, ">> log.txt";
print FILE "------------------------------------------------------------------------\n";
print FILE localtime() . "\n";
print FILE "$output\n";
print FILE "========================================================================\n";
close FILE;
}
if(exists $self->{options}->{'-paste'} or (defined $self->{got_run} and $self->{got_run} eq "paste")) {
my $flags = "";
=cut
$extracted_args =~ s/-paste //g;
if(length $extracted_args) {
$extracted_args =~ s/\s*$//;
$flags .= '[' . $extracted_args . '] ';
}
if(length $args) {
$flags .= "gcc " . $args . " -o $self->{execfile} $self->{sourcefile}";
} else {
$flags .= $languages{$lang} . " -o $self->{execfile} $self->{sourcefile}";
}
=cut
my $pretty_code = $self->pretty_format($self->{code});
$pretty_code .= "\n\n/************* COMPILER FLAGS *************\n$flags\n************** COMPILER FLAGS *************/\n";
$output =~ s/\s+$//;
$pretty_code .= "\n/************* OUTPUT *************\n$output\n************** OUTPUT *************/\n";
my $uri = paste_sprunge($pretty_code);
print "$self->{nick}: $uri\n";
exit 0;
}
if(length $output > 22 and open FILE, "< history/$self->{channel}-$self->{lang}.last-output") {
my $last_output;
my $time = <FILE>;
if(gettimeofday - $time > 60 * 10) {
close FILE;
} else {
while(my $line = <FILE>) {
$last_output .= $line;
}
close FILE;
if($last_output eq $output) {
print "$self->{nick}: Same output.\n";
exit 0;
}
}
}
print "$self->{nick}: $output\n";
open FILE, "> history/$self->{channel}-$self->{lang}.last-output" or die "Couldn't open $self->{channel}-$self->{lang}.last-output: $!";
my $now = gettimeofday;
print FILE "$now\n";
print FILE "$output";
close FILE;
}
sub paste_codepad {
my $self = shift;
my $text = join(' ', @_);
$text =~ s/(.{120})\s/$1\n/g;
my $ua = LWP::UserAgent->new();
$ua->agent("Mozilla/5.0");
push @{ $ua->requests_redirectable }, 'POST';
my %post = ( 'lang' => 'C', 'code' => $text, 'private' => 'True', 'submit' => 'Submit' );
my $response = $ua->post("http://codepad.org", \%post);
if(not $response->is_success) {
return $response->status_line;
}
return $response->request->uri;
}
sub paste_sprunge {
my $self = shift;
my $text = join(' ', @_);
$text =~ s/(.{120})\s/$1\n/g;
my $ua = LWP::UserAgent->new();
$ua->agent("Mozilla/5.0");
$ua->requests_redirectable([ ]);
my %post = ( 'sprunge' => $text, 'submit' => 'Submit' );
my $response = $ua->post("http://sprunge.us", \%post);
if(not $response->is_success) {
return $response->status_line;
}
my $result = $response->content;
$result =~ s/^\s+//;
$result =~ s/\s+$/?c/;
return $result;
}
sub execute {
my ($self, $local) = @_;
my ($compiler, $compiler_output, $pid);
if(defined $local and $local != 0) {
print "Using local compiler instead of virtual machine\n";
$pid = open2($compiler_output, $compiler, './compiler_vm_server.pl') || die "repl failed: $@\n";
print "Started compiler, pid: $pid\n";
} else {
$compiler = IO::Socket::INET->new(PeerAddr => '127.0.0.1', PeerPort => $EXECUTE_PORT, Proto => 'tcp', Type => SOCK_STREAM);
die "Could not create socket: $!" unless $compiler;
$compiler_output = $compiler;
}
my $date = time;
my $input = $self->{options}->{'-input'};
$input = `fortune -u -s` if not length $input;
$input =~ s/[\n\r\t]/ /msg;
$input =~ s/:/ - /g;
$input =~ s/\s+/ /g;
$input =~ s/^\s+//;
$input =~ s/\s+$//;
my $pretty_code = $self->pretty_format($self->{code});
my $cmdline = $self->{cmdline};
$cmdline .= ' -paste' if exists $self->{options}->{'-paste'};
$cmdline =~ s/\$sourcefile/$self->{sourcefile}/g;
$cmdline =~ s/\$execfile/$self->{execfile}/g;
if (length $self->{cmdline_options}) {
$cmdline =~ s/\$options/$self->{cmdline_options}/g;
} else {
$cmdline =~ s/\$options/$self->{default_options}/g;
}
open FILE, ">> log.txt";
print FILE "------------------------------------------------------------------------\n";
print FILE localtime() . "\n";
print FILE "$cmdline\n$input\n$pretty_code\n";
close FILE;
print $compiler "compile:$self->{lang}:$self->{sourcefile}:$self->{execfile}:$cmdline:$input:$date\n";
print $compiler "$pretty_code\n";
print $compiler "compile:end\n";
my $result = "";
my $got_result = 0;
while(my $line = <$compiler_output>) {
$line =~ s/[\r\n]+$//;
last if $line =~ /^result:end$/;
if($line =~ /^result:/) {
$line =~ s/^result://;
$result .= "$line\n";
$got_result = 1;
next;
}
if($got_result) {
$result .= "$line\n";
}
}
close $compiler;
waitpid($pid, 0) if defined $pid;
$self->{output} = $result;
return $result;
}
sub add_option {
my $self = shift;
my ($option, $value) = @_;
$self->{options_order} = [] if not exists $self->{options_order};
$self->{options}->{$option} = $value;
push $self->{options_order}, $option;
}
sub process_standard_options {
my $self = shift;
my $code = $self->{code};
if ($code =~ s/-(?:input|stdin)=(.*)$//i) {
$self->add_option("-input", $1);
}
if ($code =~ s/(?:^|(?<=\s))-paste\s*//i) {
$self->add_option("-paste");
}
$self->{code} = $code;
}
sub process_custom_options {
}
sub process_cmdline_options {
my $self = shift;
my $code = $self->{code};
$self->{cmdline_options} = "";
while ($code =~ s/^\s*(-[^ ]+)\s*//) {
$self->{cmdline_options} .= "$1 ";
$self->add_option($1);
}
$self->{cmdline_options} =~ s/\s$//;
$self->{code} = $code;
}
sub process_interactive_edit {
my $self = shift;
my $code = $self->{code};
my (@last_code, $save_last_code, $unshift_last_code);
print " code: [$code]\n" if $self->{debug};
my $subcode = $code;
while ($subcode =~ s/^\s*(-[^ ]+)\s*//) {}
my $copy_code;
if($subcode =~ s/^\s*copy\s+(\S+)\s*//) {
my $copy = $1;
if(open FILE, "< history/$copy-$self->{lang}.hist") {
$copy_code = <FILE>;
close FILE;
goto COPY_ERROR if not $copy_code;;
chomp $copy_code;
} else {
goto COPY_ERROR;
}
goto COPY_SUCCESS;
COPY_ERROR:
print "$self->{nick}: No history for $copy.\n";
exit 0;
COPY_SUCCESS:
$code = $copy_code;
$self->{only_show} = 1;
$self->{copy_code} = 1;
$save_last_code = 1;
}
if($subcode =~ m/^\s*(?:and\s+)?(?:diff|show)\s+(\S+)\s*$/) {
$self->{channel} = $1;
}
if(open FILE, "< history/$self->{channel}-$self->{lang}.hist") {
while(my $line = <FILE>) {
chomp $line;
push @last_code, $line;
}
close FILE;
}
unshift @last_code, $copy_code if defined $copy_code;
if($subcode =~ m/^\s*(?:and\s+)?show(?:\s+\S+)?\s*$/i) {
if(defined $last_code[0]) {
print "$self->{nick}: $last_code[0]\n";
} else {
print "$self->{nick}: No recent code to show.\n"
}
exit 0;
}
if($subcode =~ m/^\s*(?:and\s+)?diff(?:\s+\S+)?\s*$/i) {
if($#last_code < 1) {
print "$self->{nick}: Not enough recent code to diff.\n"
} else {
use Text::WordDiff;
my $diff = word_diff(\$last_code[1], \$last_code[0], { STYLE => 'Diff' });
if($diff !~ /(?:<del>|<ins>)/) {
$diff = "No difference.";
} else {
$diff =~ s/<del>(.*?)(\s+)<\/del>/<del>$1<\/del>$2/g;
$diff =~ s/<ins>(.*?)(\s+)<\/ins>/<ins>$1<\/ins>$2/g;
$diff =~ s/<del>((?:(?!<del>).)*)<\/del>\s*<ins>((?:(?!<ins>).)*)<\/ins>/`replaced $1 with $2`/g;
$diff =~ s/<del>(.*?)<\/del>/`removed $1`/g;
$diff =~ s/<ins>(.*?)<\/ins>/`inserted $1`/g;
}
print "$self->{nick}: $diff\n";
}
exit 0;
}
if($subcode =~ m/^\s*(?:and\s+)?(run|paste)\s*$/i) {
$self->{got_run} = lc $1;
if(defined $last_code[0]) {
$code = $last_code[0];
$self->{only_show} = 0;
} else {
print "$self->{nick}: No recent code to $self->{got_run}.\n";
exit 0;
}
} else {
my $got_undo = 0;
my $got_sub = 0;
while($subcode =~ s/^\s*(and)?\s*undo//) {
splice @last_code, 0, 1;
if(not defined $last_code[0]) {
print "$self->{nick}: No more undos remaining.\n";
exit 0;
} else {
$code = $last_code[0];
$got_undo = 1;
}
}
my @replacements;
my $prevchange = $last_code[0];
my $got_changes = 0;
my $last_keyword;
while(1) {
$got_sub = 0;
#$got_changes = 0;
$subcode =~ s/^\s*and\s+'/and $last_keyword '/ if defined $last_keyword;
if($subcode =~ m/^\s*(and)?\s*remove \s*([^']+)?\s*'/) {
$last_keyword = 'remove';
my $modifier = 'first';
$subcode =~ s/^\s*(and)?\s*//;
$subcode =~ s/remove\s*([^']+)?\s*//i;
$modifier = $1 if defined $1;
$modifier =~ s/\s+$//;
my ($e, $r) = extract_delimited($subcode, "'");
my $text;
if(defined $e) {
$text = $e;
$text =~ s/^'//;
$text =~ s/'$//;
$subcode = "replace $modifier '$text' with ''$r";
} else {
print "$self->{nick}: Unbalanced single quotes. Usage: cc remove [all, first, .., tenth, last] 'text' [and ...]\n";
exit 0;
}
next;
}
if($subcode =~ s/^\s*(and)?\s*prepend '//) {
$last_keyword = 'prepend';
$subcode = "'$subcode";
my ($e, $r) = extract_delimited($subcode, "'");
my $text;
if(defined $e) {
$text = $e;
$text =~ s/^'//;
$text =~ s/'$//;
$subcode = $r;
$got_sub = 1;
$got_changes = 1;
if(not defined $prevchange) {
print "$self->{nick}: No recent code to prepend to.\n";
exit 0;
}
$code = $prevchange;
$code =~ s/^/$text /;
$prevchange = $code;
} else {
print "$self->{nick}: Unbalanced single quotes. Usage: cc prepend 'text' [and ...]\n";
exit 0;
}
next;
}
if($subcode =~ s/^\s*(and)?\s*append '//) {
$last_keyword = 'append';
$subcode = "'$subcode";
my ($e, $r) = extract_delimited($subcode, "'");
my $text;
if(defined $e) {
$text = $e;
$text =~ s/^'//;
$text =~ s/'$//;
$subcode = $r;
$got_sub = 1;
$got_changes = 1;
if(not defined $prevchange) {
print "$self->{nick}: No recent code to append to.\n";
exit 0;
}
$code = $prevchange;
$code =~ s/$/ $text/;
$prevchange = $code;
} else {
print "$self->{nick}: Unbalanced single quotes. Usage: cc append 'text' [and ...]\n";
exit 0;
}
next;
}
if($subcode =~ m/^\s*(and)?\s*replace\s*([^']+)?\s*'.*'\s*with\s*'.*?'/i) {
$last_keyword = 'replace';
$got_sub = 1;
my $modifier = 'first';
$subcode =~ s/^\s*(and)?\s*//;
$subcode =~ s/replace\s*([^']+)?\s*//i;
$modifier = $1 if defined $1;
$modifier =~ s/\s+$//;
my ($from, $to);
my ($e, $r) = extract_delimited($subcode, "'");
if(defined $e) {
$from = $e;
$from =~ s/^'//;
$from =~ s/'$//;
$from = quotemeta $from;
$subcode = $r;
$subcode =~ s/\s*with\s*//i;
} else {
print "$self->{nick}: Unbalanced single quotes. Usage: cc replace 'from' with 'to' [and ...]\n";
exit 0;
}
($e, $r) = extract_delimited($subcode, "'");
if(defined $e) {
$to = $e;
$to =~ s/^'//;
$to =~ s/'$//;
$subcode = $r;
} else {
print "$self->{nick}: Unbalanced single quotes. Usage: cc replace 'from' with 'to' [and replace ... with ... [and ...]]\n";
exit 0;
}
given($modifier) {
when($_ eq 'all' ) {}
when($_ eq 'last' ) {}
when($_ eq 'first' ) { $modifier = 1; }
when($_ eq 'second' ) { $modifier = 2; }
when($_ eq 'third' ) { $modifier = 3; }
when($_ eq 'fourth' ) { $modifier = 4; }
when($_ eq 'fifth' ) { $modifier = 5; }
when($_ eq 'sixth' ) { $modifier = 6; }
when($_ eq 'seventh') { $modifier = 7; }
when($_ eq 'eighth' ) { $modifier = 8; }
when($_ eq 'nineth' ) { $modifier = 9; }
when($_ eq 'tenth' ) { $modifier = 10; }
default { print "$self->{nick}: Bad replacement modifier '$modifier'; valid modifiers are 'all', 'first', 'second', ..., 'tenth', 'last'\n"; exit 0; }
}
my $replacement = {};
$replacement->{'from'} = $from;
$replacement->{'to'} = $to;
$replacement->{'modifier'} = $modifier;
push @replacements, $replacement;
next;
}
if($subcode =~ m/^\s*(and)?\s*s\/.*\//) {
$last_keyword = undef;
$got_sub = 1;
$subcode =~ s/^\s*(and)?\s*s//;
my ($regex, $to);
my ($e, $r) = extract_delimited($subcode, '/');
if(defined $e) {
$regex = $e;
$regex =~ s/^\///;
$regex =~ s/\/$//;
$subcode = "/$r";
} else {
print "$self->{nick}: Unbalanced slashes. Usage: cc s/regex/substitution/[gi] [and s/.../.../ [and ...]]\n";
exit 0;
}
($e, $r) = extract_delimited($subcode, '/');
if(defined $e) {
$to = $e;
$to =~ s/^\///;
$to =~ s/\/$//;
$subcode = $r;
} else {
print "$self->{nick}: Unbalanced slashes. Usage: cc s/regex/substitution/[gi] [and s/.../.../ [and ...]]\n";
exit 0;
}
my $suffix;
$suffix = $1 if $subcode =~ s/^([^ ]+)//;
if(length $suffix and $suffix =~ m/[^gi]/) {
print "$self->{nick}: Bad regex modifier '$suffix'. Only 'i' and 'g' are allowed.\n";
exit 0;
}
if(defined $prevchange) {
$code = $prevchange;
} else {
print "$self->{nick}: No recent code to change.\n";
exit 0;
}
my $ret = eval {
my ($ret, $a, $b, $c, $d, $e, $f, $g, $h, $i, $before, $after);
if(not length $suffix) {
$ret = $code =~ s|$regex|$to|;
($a, $b, $c, $d, $e, $f, $g, $h, $i) = ($1, $2, $3, $4, $5, $6, $7, $8, $9);
$before = $`;
$after = $';
} elsif($suffix =~ /^i$/) {
$ret = $code =~ s|$regex|$to|i;
($a, $b, $c, $d, $e, $f, $g, $h, $i) = ($1, $2, $3, $4, $5, $6, $7, $8, $9);
$before = $`;
$after = $';
} elsif($suffix =~ /^g$/) {
$ret = $code =~ s|$regex|$to|g;
($a, $b, $c, $d, $e, $f, $g, $h, $i) = ($1, $2, $3, $4, $5, $6, $7, $8, $9);
$before = $`;
$after = $';
} elsif($suffix =~ /^ig$/ or $suffix =~ /^gi$/) {
$ret = $code =~ s|$regex|$to|gi;
($a, $b, $c, $d, $e, $f, $g, $h, $i) = ($1, $2, $3, $4, $5, $6, $7, $8, $9);
$before = $`;
$after = $';
}
if($ret) {
$code =~ s/\$1/$a/g;
$code =~ s/\$2/$b/g;
$code =~ s/\$3/$c/g;
$code =~ s/\$4/$d/g;
$code =~ s/\$5/$e/g;
$code =~ s/\$6/$f/g;
$code =~ s/\$7/$g/g;
$code =~ s/\$8/$h/g;
$code =~ s/\$9/$i/g;
$code =~ s/\$`/$before/g;
$code =~ s/\$'/$after/g;
}
return $ret;
};
if($@) {
my $error = $@;
$error =~ s/ at .* line \d+\.\s*$//;
print "$self->{nick}: $error\n";
exit 0;
}
if($ret) {
$got_changes = 1;
}
$prevchange = $code;
}
if($got_sub and not $got_changes) {
print "$self->{nick}: No substitutions made.\n";
exit 0;
} elsif($got_sub and $got_changes) {
next;
}
last;
}
if($#replacements > -1) {
use re::engine::RE2 -strict => 1;
@replacements = sort { $a->{'from'} cmp $b->{'from'} or $a->{'modifier'} <=> $b->{'modifier'} } @replacements;
my ($previous_from, $previous_modifier);
foreach my $replacement (@replacements) {
my $from = $replacement->{'from'};
my $to = $replacement->{'to'};
my $modifier = $replacement->{'modifier'};
if(defined $previous_from) {
if($previous_from eq $from and $previous_modifier =~ /^\d+$/) {
$modifier -= $modifier - $previous_modifier;
}
}
if(defined $prevchange) {
$code = $prevchange;
} else {
print "$self->{nick}: No recent code to change.\n";
exit 0;
}
my $ret = eval {
my $got_change;
my ($first_char, $last_char, $first_bound, $last_bound);
$first_char = $1 if $from =~ m/^(.)/;
$last_char = $1 if $from =~ m/(.)$/;
if($first_char =~ /\W/) {
$first_bound = '.';
} else {
$first_bound = '\b';
}
if($last_char =~ /\W/) {
$last_bound = '\B';
} else {
$last_bound = '\b';
}
if($modifier eq 'all') {
if($code =~ s/($first_bound)$from($last_bound)/$1$to$2/g) {
$got_change = 1;
}
} elsif($modifier eq 'last') {
if($code =~ s/(.*)($first_bound)$from($last_bound)/$1$2$to$3/) {
$got_change = 1;
}
} else {
my $count = 0;
my $unescaped = $from;
$unescaped =~ s/\\//g;
if($code =~ s/($first_bound)$from($last_bound)/if(++$count == $modifier) { "$1$to$2"; } else { "$1$unescaped$2"; }/ge) {
$got_change = 1;
}
}
return $got_change;
};
if($@) {
my $error = $@;
$error =~ s/ at .* line \d+\.\s*$//;
print "$self->{nick}: $error\n";
exit 0;
}
if($ret) {
$got_sub = 1;
$got_changes = 1;
}
$prevchange = $code;
$previous_from = $from;
$previous_modifier = $modifier;
}
if(not $got_changes) {
print "$self->{nick}: No replacements made.\n";
exit 0;
}
}
$save_last_code = 1;
unless($got_undo and not $got_changes) {
$unshift_last_code = 1 unless $copy_code and not $got_changes;
}
if($copy_code and $got_changes) {
$self->{only_show} = 0;
}
if($got_undo and not $got_changes) {
$self->{only_show} = 1;
}
}
if($save_last_code) {
if($unshift_last_code) {
unshift @last_code, $code;
}
open FILE, "> history/$self->{channel}-$self->{lang}.hist";
my $i = 0;
foreach my $line (@last_code) {
last if(++$i > $self->{max_history});
print FILE "$line\n";
}
close FILE;
}
$self->{code} = $code;
}
1;

507
modules/compiler_vm/languages/c11.pm Executable file
View File

@ -0,0 +1,507 @@
#!/usr/bin/perl
use warnings;
use strict;
use feature "switch";
no if $] >= 5.018, warnings => "experimental::smartmatch";
package c11;
use parent '_default';
use Text::Balanced qw/extract_bracketed/;
sub initialize {
my ($self, %conf) = @_;
$self->{sourcefile} = 'prog.c';
$self->{execfile} = 'prog';
$self->{default_options} = '-Wextra -Wall -Wno-unused -pedantic -Wfloat-equal -Wshadow -std=c11 -lm -Wfatal-errors';
$self->{cmdline} = 'gcc -ggdb -g3 $sourcefile $options -o $execfile';
$self->{prelude} = <<'END';
#define _XOPEN_SOURCE 9001
#define __USE_XOPEN
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <unistd.h>
#include <math.h>
#include <limits.h>
#include <sys/types.h>
#include <stdint.h>
#include <stdbool.h>
#include <stddef.h>
#include <stdarg.h>
#include <stdnoreturn.h>
#include <stdalign.h>
#include <ctype.h>
#include <inttypes.h>
#include <float.h>
#include <errno.h>
#include <time.h>
#include <assert.h>
#include <complex.h>
#include <setjmp.h>
#include <wchar.h>
#include <wctype.h>
#include <tgmath.h>
#include <fenv.h>
#include <locale.h>
#include <iso646.h>
#include <signal.h>
#include <uchar.h>
#include <prelude.h>
END
}
sub process_custom_options {
my $self = shift;
$self->{code} = $self->{code};
$self->add_option("-nomain") if $self->{code} =~ s/(?:^|(?<=\s))-nomain\s*//i;
$self->{include_options} = "";
while ($self->{code} =~ s/(?:^|(?<=\s))-include\s+(\S+)\s+//) {
$self->{include_options} .= "#include <$1> ";
$self->add_option("-include $1");
}
$self->{code} = $self->{code};
}
sub pretty_format {
my $self = shift;
my $code = join '', @_;
my $result;
$code = $self->{code} if not defined $code;
open my $fh, ">$self->{sourcefile}" or die "Couldn't write $self->{sourcefile}: $!";
print $fh $code;
close $fh;
system("astyle", "-UHfenq", $self->{sourcefile});
open $fh, "<$self->{sourcefile}" or die "Couldn't read $self->{sourcefile}: $!";
$result = join '', <$fh>;
close $fh;
return $result;
}
sub preprocess_code {
my $self = shift;
$self->SUPER::preprocess_code;
my $default_prelude = $self->{prelude};
$self->{code} = $self->{include_options} . $self->{code};
print "code before: [$self->{code}]\n" if $self->{debug};
# replace \n outside of quotes with literal newline
my $new_code = "";
use constant {
NORMAL => 0,
DOUBLE_QUOTED => 1,
SINGLE_QUOTED => 2,
};
my $state = NORMAL;
my $escaped = 0;
while($self->{code} =~ m/(.)/gs) {
my $ch = $1;
given ($ch) {
when ('\\') {
if($escaped == 0) {
$escaped = 1;
next;
}
}
if($state == NORMAL) {
when ($_ eq '"' and not $escaped) {
$state = DOUBLE_QUOTED;
}
when ($_ eq "'" and not $escaped) {
$state = SINGLE_QUOTED;
}
when ($_ eq 'n' and $escaped == 1) {
$ch = "\n";
$escaped = 0;
}
}
if($state == DOUBLE_QUOTED) {
when ($_ eq '"' and not $escaped) {
$state = NORMAL;
}
}
if($state == SINGLE_QUOTED) {
when ($_ eq "'" and not $escaped) {
$state = NORMAL;
}
}
}
$new_code .= '\\' and $escaped = 0 if $escaped;
$new_code .= $ch;
}
$self->{code} = $new_code;
print "code after \\n replacement: [$self->{code}]\n" if $self->{debug};
# add newlines to ends of statements and #includes
my $single_quote = 0;
my $double_quote = 0;
my $parens = 0;
my $cpp = 0; # preprocessor
$escaped = 0;
while($self->{code} =~ m/(.)/msg) {
my $ch = $1;
my $pos = pos $self->{code};
print "adding newlines, ch = [$ch], parens: $parens, cpp: $cpp, single: $single_quote, double: $double_quote, escaped: $escaped, pos: $pos\n" if $self->{debug} >= 10;
if($ch eq '\\') {
$escaped = not $escaped;
} elsif($ch eq '#' and not $cpp and not $escaped and not $single_quote and not $double_quote) {
$cpp = 1;
if($self->{code} =~ m/include\s*<([^>\n]*)>/msg) {
my $match = $1;
$pos = pos $self->{code};
substr ($self->{code}, $pos, 0) = "\n";
pos $self->{code} = $pos;
$cpp = 0;
} elsif($self->{code} =~ m/include\s*"([^"\n]*)"/msg) {
my $match = $1;
$pos = pos $self->{code};
substr ($self->{code}, $pos, 0) = "\n";
pos $self->{code} = $pos;
$cpp = 0;
} else {
pos $self->{code} = $pos;
}
} elsif($ch eq '"') {
$double_quote = not $double_quote unless $escaped or $single_quote;
$escaped = 0;
} elsif($ch eq '(' and not $single_quote and not $double_quote) {
$parens++;
} elsif($ch eq ')' and not $single_quote and not $double_quote) {
$parens--;
$parens = 0 if $parens < 0;
} elsif($ch eq ';' and not $cpp and not $single_quote and not $double_quote and $parens == 0) {
if(not substr($self->{code}, $pos, 1) =~ m/[\n\r]/) {
substr ($self->{code}, $pos, 0) = "\n";
pos $self->{code} = $pos + 1;
}
} elsif($ch eq "'") {
$single_quote = not $single_quote unless $escaped or $double_quote;
$escaped = 0;
} elsif($ch eq 'n' and $escaped) {
if(not $single_quote and not $double_quote) {
print "added newline\n" if $self->{debug} >= 10;
substr ($self->{code}, $pos - 2, 2) = "\n";
pos $self->{code} = $pos;
$cpp = 0;
}
$escaped = 0;
} elsif($ch eq '{' and not $cpp and not $single_quote and not $double_quote) {
if(not substr($self->{code}, $pos, 1) =~ m/[\n\r]/) {
substr ($self->{code}, $pos, 0) = "\n";
pos $self->{code} = $pos + 1;
}
} elsif($ch eq '}' and not $cpp and not $single_quote and not $double_quote) {
if(not substr($self->{code}, $pos, 1) =~ m/[\n\r;]/) {
substr ($self->{code}, $pos, 0) = "\n";
pos $self->{code} = $pos + 1;
}
} elsif($ch eq "\n" and $cpp and not $single_quote and not $double_quote) {
$cpp = 0;
} else {
$escaped = 0;
}
}
print "code after \\n additions: [$self->{code}]\n" if $self->{debug};
# white-out contents of quoted literals so content within literals aren't parsed as code
my $white_code = $self->{code};
$white_code =~ s/(?:\"((?:\\\"|(?!\").)*)\")/'"' . ('-' x length $1) . '"'/ge;
$white_code =~ s/(?:\'((?:\\\'|(?!\').)*)\')/"'" . ('-' x length $1) . "'"/ge;
my $precode;
if($white_code =~ m/#include/) {
$precode = $self->{code};
} else {
$precode = $default_prelude . $self->{code};
}
$self->{code} = '';
print "--- precode: [$precode]\n" if $self->{debug};
$self->{warn_unterminated_define} = 0;
my $has_main = 0;
my $prelude = '';
while($precode =~ s/^\s*(#.*\n{1,2})//g) {
$prelude .= $1;
}
if($precode =~ m/^\s*(#.*)/ms) {
my $line = $1;
if($line !~ m/\n/) {
$self->{warn_unterminated_define} = 1;
}
}
print "*** prelude: [$prelude]\n precode: [$precode]\n" if $self->{debug};
my $preprecode = $precode;
# white-out contents of quoted literals
$preprecode =~ s/(?:\"((?:\\\"|(?!\").)*)\")/'"' . ('-' x length $1) . '"'/ge;
$preprecode =~ s/(?:\'((?:\\\'|(?!\').)*)\')/"'" . ('-' x length $1) . "'"/ge;
# strip comments
if ($self->{lang} eq 'c89') {
$preprecode =~ s#/\*[^*]*\*+([^/*][^*]*\*+)*/# #gs;
$preprecode =~ s#|//([^\\]|[^\n][\n]?)*?\n|("(\\.|[^"\\])*"|'(\\.|[^'\\])*'|.[^/"'\\]*)#defined $2 ? $2 : ""#gse;
} else {
$preprecode =~ s#|//([^\\]|[^\n][\n]?)*?\n|("(\\.|[^"\\])*"|'(\\.|[^'\\])*'|.[^/"'\\]*)#defined $2 ? $2 : ""#gse;
$preprecode =~ s#/\*[^*]*\*+([^/*][^*]*\*+)*/# #gs;
}
print "preprecode: [$preprecode]\n" if $self->{debug};
print "looking for functions, has main: $has_main\n" if $self->{debug} >= 2;
my $func_regex = qr/^([ *\w]+)\s+([ ()*\w]+)\s*\(([^;{]*)\s*\)\s*({.*|<%.*|\?\?<.*)/ims;
# look for potential functions to extract
while($preprecode =~ /$func_regex/ms) {
my ($pre_ret, $pre_ident, $pre_params, $pre_potential_body) = ($1, $2, $3, $4);
my $precode_code;
print "looking for functions, found [$pre_ret][$pre_ident][$pre_params][$pre_potential_body], has main: $has_main\n" if $self->{debug} >= 1;
# find the pos at which this function lives, for extracting from precode
$preprecode =~ m/(\Q$pre_ret\E\s+\Q$pre_ident\E\s*\(\s*\Q$pre_params\E\s*\)\s*\Q$pre_potential_body\E)/g;
my $extract_pos = (pos $preprecode) - (length $1);
# now that we have the pos, substitute out the extracted potential function from preprecode
$preprecode =~ s/$func_regex//ms;
# create tmpcode object that starts from extract pos, to skip any quoted code
my $tmpcode = substr($precode, $extract_pos);
print "tmpcode: [$tmpcode]\n" if $self->{debug};
$precode = substr($precode, 0, $extract_pos);
print "precode: [$precode]\n" if $self->{debug};
$precode_code = $precode;
$tmpcode =~ m/$func_regex/ms;
my ($ret, $ident, $params, $potential_body) = ($1, $2, $3, $4);
print "1st extract: [$ret][$ident][$params][$potential_body]\n" if $self->{debug};
$ret =~ s/^\s+//;
$ret =~ s/\s+$//;
if(not length $ret or $ret eq "else" or $ret eq "while" or $ret eq "if" or $ret eq "for" or $ident eq "for" or $ident eq "while" or $ident eq "if") {
$precode .= "$ret $ident ($params) $potential_body";
next;
} else {
$tmpcode =~ s/$func_regex//ms;
}
$potential_body =~ s/^\s*<%/{/ms;
$potential_body =~ s/%>\s*$/}/ms;
$potential_body =~ s/^\s*\?\?</{/ms;
$potential_body =~ s/\?\?>$/}/ms;
my @extract = extract_bracketed($potential_body, '{}');
my $body;
if(not defined $extract[0]) {
if($self->{debug} == 0) {
print "error: unmatched brackets\n";
} else {
print "error: unmatched brackets for function '$ident';\n";
print "body: [$potential_body]\n";
}
exit;
} else {
$body = $extract[0];
$preprecode = $extract[1];
$precode = $extract[1];
}
print "final extract: [$ret][$ident][$params][$body]\n" if $self->{debug};
$self->{code} .= "$precode_code\n$ret $ident($params) $body\n";
if($self->{debug} >= 2) { print '-' x 20 . "\n" }
print " code: [$self->{code}]\n" if $self->{debug} >= 2;
if($self->{debug} >= 2) { print '-' x 20 . "\n" }
print " precode: [$precode]\n" if $self->{debug} >= 2;
$has_main = 1 if $ident =~ m/^\s*\(?\s*main\s*\)?\s*$/;
}
$precode =~ s/^\s+//;
$precode =~ s/\s+$//;
$precode =~ s/^{(.*)}$/$1/s;
if(not $has_main and not exists $self->{options}->{'-nomain'}) {
$self->{code} = "$prelude\n$self->{code}\n" . "int main(void) {\n$precode\n;\nreturn 0;\n}\n";
} else {
$self->{code} = "$prelude\n$self->{code}\n";
}
print "after func extract, code: [$self->{code}]\n" if $self->{debug};
$self->{code} =~ s/\|n/\n/g;
$self->{code} =~ s/^\s+//;
$self->{code} =~ s/\s+$//;
$self->{code} =~ s/;\s*;\n/;\n/gs;
$self->{code} =~ s/;(\s*\/\*.*?\*\/\s*);\n/;$1/gs;
$self->{code} =~ s/;(\s*\/\/.*?\s*);\n/;$1/gs;
$self->{code} =~ s/({|})\n\s*;\n/$1\n/gs;
$self->{code} =~ s/(?:\n\n)+/\n\n/g;
print "final code: [$self->{code}]\n" if $self->{debug};
}
sub postprocess_output {
my $self = shift;
$self->SUPER::postprocess_output;
my $output = $self->{output};
$output =~ s/In file included from .*?:\d+:\d+.\s*from $self->{sourcefile}:\d+.\s*//msg;
$output =~ s/In file included from .*?:\d+:\d+.\s*//msg;
$output =~ s/\s*from $self->{sourcefile}:\d+.\s*//g;
$output =~ s/$self->{execfile}: $self->{sourcefile}:\d+: [^:]+: Assertion/Assertion/g;
$output =~ s,/usr/include/[^:]+:\d+:\d+:\s+,,g;
unless(exists $self->{options}->{'-paste'} or (defined $self->{got_run} and $self->{got_run} eq "paste")) {
$output =~ s/ Line \d+ ://g;
$output =~ s/$self->{sourcefile}:[:\d]*//g;
} else {
$output =~ s/$self->{sourcefile}:(\d+)/\n$1/g;
$output =~ s/$self->{sourcefile}://g;
}
$output =~ s/;?\s?__PRETTY_FUNCTION__ = "[^"]+"//g;
$output =~ s/(\d+:\d+:\s*)*cc1: (all\s+)?warnings being treated as errors//;
$output =~ s/(\d+:\d+:\s*)* \(first use in this function\)//g;
$output =~ s/(\d+:\d+:\s*)*error: \(Each undeclared identifier is reported only once.*?\)//msg;
$output =~ s/(\d+:\d+:\s*)*ld: warning: cannot find entry symbol _start; defaulting to [^ ]+//;
$output =~ s/(\d+:\d+:\s*)*\/tmp\/.*\.o://g;
$output =~ s/(\d+:\d+:\s*)*collect2: ld returned \d+ exit status//g;
$output =~ s/\(\.text\+[^)]+\)://g;
$output =~ s/\[ In/[In/;
$output =~ s/(\d+:\d+:\s*)*warning: Can't read pathname for load map: Input.output error.//g;
my $left_quote = chr(226) . chr(128) . chr(152);
my $right_quote = chr(226) . chr(128) . chr(153);
$output =~ s/$left_quote/'/msg;
$output =~ s/$right_quote/'/msg;
$output =~ s/`/'/msg;
$output =~ s/\t/ /g;
if($output =~ /In function '([^']+)':/) {
if($1 eq 'main') {
$output =~ s/(\d+:\d+:\s*)*\s?In function .main.:\s*//g;
} else {
$output =~ s/(\d+:\d+:\s*)*\s?In function .main.:\s?/In function 'main':/g;
}
}
$output =~ s/(\d+:\d+:\s*)*warning: unknown conversion type character 'b' in format \[-Wformat=?\]\s+(\d+:\d+:\s*)*warning: too many arguments for format \[-Wformat-extra-args\]/info: %b is a candide extension/g;
$output =~ s/(\d+:\d+:\s*)*warning: unknown conversion type character 'b' in format \[-Wformat=?\]//g;
$output =~ s/\s\(core dumped\)/./;
$output =~ s/ \[enabled by default\]//g;
$output =~ s/initializer\s+warning: \(near/initializer (near/g;
$output =~ s/(\d+:\d+:\s*)*note: each undeclared identifier is reported only once for each function it appears in//g;
$output =~ s/\(gdb\)//g;
$output =~ s/", '\\(\d{3})' <repeats \d+ times>,? ?"/\\$1/g;
$output =~ s/, '\\(\d{3})' <repeats \d+ times>\s*//g;
$output =~ s/(\\000)+/\\0/g;
$output =~ s/\\0[^">']+/\\0/g;
$output =~ s/= (\d+) '\\0'/= $1/g;
$output =~ s/\\0"/"/g;
$output =~ s/"\\0/"/g;
$output =~ s/\.\.\.>/>/g;
$output =~ s/<\s*included at \/home\/compiler\/>\s*//g;
$output =~ s/\s*compilation terminated due to -Wfatal-errors\.//g;
$output =~ s/^======= Backtrace.*\[vsyscall\]\s*$//ms;
$output =~ s/glibc detected \*\*\* \/home\/compiler\/$self->{execfile}: //;
$output =~ s/: \/home\/compiler\/$self->{execfile} terminated//;
$output =~ s/<Defined at \/home\/compiler\/>/<Defined at \/home\/compiler\/$self->{sourcefile}:0>/g;
$output =~ s/\s*In file included from\s+\/usr\/include\/.*?:\d+:\d+:\s*/, /g;
$output =~ s/\s*collect2: error: ld returned 1 exit status//g;
$output =~ s/In function\s*`main':\s*\/home\/compiler\/ undefined reference to/error: undefined reference to/g;
$output =~ s/\/home\/compiler\///g;
$output =~ s/compilation terminated.//;
$output =~ s/'(.*?)' = char/'$1' = int/g; $output =~ s/(\(\s*char\s*\)\s*'.*?') = int/$1 = char/; # gdb thinks 'a' is type char, which is not true for C
$output =~ s/= (-?\d+) ''/= $1/g;
$output =~ s/, <incomplete sequence >//g;
$output =~ s/\s*warning: shadowed declaration is here \[-Wshadow\]//g unless exists $self->{options}->{'-paste'} or (defined $self->{got_run} and $self->{got_run} eq 'paste');
$output =~ s/\s*note: shadowed declaration is here//g unless exists $self->{options}->{'-paste'} or (defined $self->{got_run} and $self->{got_run} eq 'paste');
$output =~ s/preprocessor macro>\s+<at\s+>/preprocessor macro>/g;
$output =~ s/<No symbol table is loaded. Use the "file" command.>\s*//g;
$output =~ s/cc1: all warnings being treated as; errors//g;
$output =~ s/, note: this is the location of the previous definition//g;
$output =~ s/ called by gdb \(\) at statement: void gdb\(\) { __asm__\(""\); }//g;
my $removed_warning = 0;
$removed_warning++ if $output =~ s/warning: ISO C forbids nested functions \[-pedantic\]\s*//g;
if($removed_warning) {
$output =~ s/^\[\]\s*//;
}
$output =~ s/^\[\s+(warning:|info:)/[$1/; # remove leading spaces in first warning/info
# backspace
my $boutput = "";
my $active_position = 0;
$output =~ s/\n$//;
while($output =~ /(.)/gms) {
my $c = $1;
if($c eq "\b") {
if(--$active_position <= 0) {
$active_position = 0;
}
next;
}
substr($boutput, $active_position++, 1) = $c;
}
$output = $boutput;
if($self->{warn_unterminated_define} == 1) {
if($output =~ m/^\[(warning:|info:)/) {
$output =~ s/^\[/[warning: preprocessor directive not terminated by \\n, the remainder of the line will be part of this directive /;
} else {
$output =~ s/^/[warning: preprocessor directive not terminated by \\n, the remainder of the line will be part of this directive] /;
}
}
$self->{output} = $output;
}
1;

39
modules/compiler_vm/languages/c89.pm Executable file
View File

@ -0,0 +1,39 @@
#!/usr/bin/perl
use warnings;
use strict;
package c89;
use parent 'c11';
sub initialize {
my ($self, %conf) = @_;
$self->{sourcefile} = 'prog.c';
$self->{execfile} = 'prog';
$self->{default_options} = '-Wextra -Wall -Wno-unused -pedantic -Wfloat-equal -Wshadow -std=c89 -lm -Wfatal-errors';
$self->{cmdline} = 'gcc -ggdb -g3 $sourcefile $options -o $execfile';
$self->{prelude} = <<'END';
#define _XOPEN_SOURCE 9001
#define __USE_XOPEN
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <unistd.h>
#include <math.h>
#include <limits.h>
#include <sys/types.h>
#include <stdint.h>
#include <errno.h>
#include <ctype.h>
#include <assert.h>
#include <locale.h>
#include <setjmp.h>
#include <signal.h>
#include <prelude.h>
END
}
1;

50
modules/compiler_vm/languages/c99.pm Executable file
View File

@ -0,0 +1,50 @@
#!/usr/bin/perl
use warnings;
use strict;
package c99;
use parent 'c11';
sub initialize {
my ($self, %conf) = @_;
$self->{sourcefile} = 'prog.c';
$self->{execfile} = 'prog';
$self->{default_options} = '-Wextra -Wall -Wno-unused -pedantic -Wfloat-equal -Wshadow -std=c99 -lm -Wfatal-errors';
$self->{cmdline} = 'gcc -ggdb -g3 $sourcefile $options -o $execfile';
$self->{prelude} = <<'END';
#define _XOPEN_SOURCE 9001
#define __USE_XOPEN
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <unistd.h>
#include <complex.h>
#include <math.h>
#include <tgmath.h>
#include <limits.h>
#include <sys/types.h>
#include <stdint.h>
#include <stdbool.h>
#include <stddef.h>
#include <stdarg.h>
#include <ctype.h>
#include <inttypes.h>
#include <float.h>
#include <errno.h>
#include <time.h>
#include <assert.h>
#include <locale.h>
#include <wchar.h>
#include <fenv.h>
#inclue <iso646.h>
#include <setjmp.h>
#include <signal.h>
#include <prelude.h>
END
}
1;

26
modules/compiler_vm/languages/perl.pm Executable file
View File

@ -0,0 +1,26 @@
#!/usr/bin/perl
use warnings;
use strict;
package perl;
use parent '_default';
sub initialize {
my ($self, %conf) = @_;
$self->{sourcefile} = 'prog.pl';
$self->{execfile} = 'prog.pl';
$self->{default_options} = '';
$self->{cmdline} = 'perl $options $sourcefile';
}
sub postprocess_output {
my $self = shift;
$self->SUPER::postprocess_output;
$self->{output} =~ s/\s+at $self->{sourcefile} line \d+, near ".*?"//;
$self->{output} =~ s/\s*Execution of $self->{sourcefile} aborted due to compilation errors.//;
}
1;

87
modules/compiler_vm/languages/server/_default.pm Executable file
View File

@ -0,0 +1,87 @@
#!/usr/bin/perl
use warnings;
use strict;
use feature "switch";
no if $] >= 5.018, warnings => "experimental::smartmatch";
package _default;
sub new {
my ($class, %conf) = @_;
my $self = bless {}, $class;
$self->{debug} = $conf{debug} // 0;
$self->{sourcefile} = $conf{sourcefile};
$self->{execfile} = $conf{execfile};
$self->{code} = $conf{code};
$self->{cmdline} = $conf{cmdline};
$self->{input} = $conf{input};
$self->{date} = $conf{date};
$self->initialize(%conf);
return $self;
}
sub initialize {
my ($self, %conf) = @_;
}
sub preprocess {
my $self = shift;
open(my $fh, '>', $self->{sourcefile}) or die $!;
print $fh $self->{code} . "\n";
close $fh;
print "Executing [$self->{cmdline}]\n";
my ($retval, $result) = $self->execute(60, $self->{cmdline});
$self->{output} = $result;
$self->{error} = $retval;
}
sub postprocess {
}
sub execute {
my $self = shift;
my $timeout = shift;
my ($cmdline) = @_;
my ($ret, $result);
($ret, $result) = eval {
print "eval\n";
my $result = '';
my $pid = open(my $fh, '-|', "$cmdline 2>&1");
local $SIG{ALRM} = sub { print "Time out\n"; kill 'TERM', $pid; die "$result [Timed-out]\n"; };
alarm($timeout);
while(my $line = <$fh>) {
$result .= $line;
}
close $fh;
my $ret = $? >> 8;
alarm 0;
return ($ret, $result);
};
print "done eval\n";
alarm 0;
if($@ =~ /Timed-out/) {
return (-1, $@);
}
print "[$ret, $result]\n";
return ($ret, $result);
}
1;

37
modules/compiler_vm/languages/server/c11.pm Executable file
View File

@ -0,0 +1,37 @@
#!/usr/bin/perl
use warnings;
use strict;
package c11;
use parent '_default';
sub postprocess {
my $self = shift;
# no errors compiling, but if output contains something, it must be diagnostic messages
if(length $self->{output}) {
$self->{output} =~ s/^\s+//;
$self->{output} =~ s/\s+$//;
$self->{output} = "[$self->{output}]\n";
}
print "Executing gdb\n";
my $input_quoted = quotemeta $self->{input};
$input_quoted =~ s/\\"/"'\\"'"/g;
my ($retval, $result) = $self->execute(60, "bash -c \"date -s \@$self->{date}; ulimit -t 1; compiler_watchdog.pl $input_quoted > .output\"");
$result = "";
open(FILE, '.output');
while(<FILE>) {
$result .= $_;
last if length $result >= 1024 * 20;
}
close(FILE);
$result =~ s/\s+$//;
$self->{output} .= $result;
}
1;

9
modules/compiler_vm/languages/server/c89.pm Executable file
View File

@ -0,0 +1,9 @@
#!/usr/bin/perl
use warnings;
use strict;
package c89;
use parent 'c11';
1;

9
modules/compiler_vm/languages/server/c99.pm Executable file
View File

@ -0,0 +1,9 @@
#!/usr/bin/perl
use warnings;
use strict;
package c99;
use parent 'c11';
1;