fork download
copy 
  1. #!/usr/bin/perl
  2.  
  3. use strict;
  4. use warnings;
  5. #use bigint;
  6. use Getopt::Std;
  7.  
  8. my $ENDMARK = '--end--';
  9. my $SLIMIT_DEFAULT=10000;
  10. my $CLEVEL_DEFAULT=3;
  11. my @inst = ();
  12. my @stack = ();
  13. my @cstack = ();
  14. my @heap = ();
  15. my %labels = ();
  16. my $ip = 0;
  17. my $continue = 1;
  18. my $skip = undef;
  19. my $inum = 0;
  20. my $bytes = 0;
  21. my $step = 0;
  22. my $stackhwm = 0;
  23. my $ibuf = '';
  24. my $codelevel;
  25. my $slimit;
  26. my $unlimited;
  27.  
  28. sub checkStack
  29. {
  30.   die "stack out of range\n" if @stack < $_[0];
  31. }
  32. sub updateHWM
  33. {
  34.   $stackhwm = @stack if $stackhwm < @stack;
  35. }
  36. sub wspush
  37. {
  38.   unshift @stack, shift;
  39.   updateHWM();
  40. }
  41. sub wsdup
  42. {
  43.   unshift @stack, $stack[0];
  44.   updateHWM();
  45. }
  46. sub wscopy
  47. {
  48.   my $pos = shift;
  49.   checkStack($pos+1);
  50.   unshift @stack, $stack[$pos];
  51.   updateHWM();
  52. }
  53. sub wsswap
  54. {
  55.   @stack[0,1] = @stack[1,0];
  56. }
  57. sub wspop
  58. {
  59.   shift @stack;
  60. }
  61. sub wsslide
  62. {
  63.   my $num = shift;
  64.   checkStack($num+1);
  65.   splice @stack, 1, $num;
  66. }
  67. sub wsadd
  68. {
  69.   my $var = shift @stack;
  70.   $stack[0] += $var;
  71. }
  72. sub wssub
  73. {
  74.   my $var = shift @stack;
  75.   $stack[0] -= $var;
  76. }
  77. sub wsmul
  78. {
  79.   my $var = shift @stack;
  80.   $stack[0] *= $var;
  81. }
  82. sub checkDivider($)
  83. {
  84.   die "0 divide exception occurred\n" if $_[0] == 0;
  85. }
  86. sub wsdiv
  87. {
  88.   my $var = shift @stack;
  89.   checkDivider($var);
  90.   $stack[0] -= $stack[0]%$var;
  91.   $stack[0] /= $var;
  92. }
  93. sub wsmod
  94. {
  95.   my $var = shift @stack;
  96.   checkDivider($var);
  97.   $stack[0] %= $var;
  98. }
  99. sub checkHeapAddress($$)
  100. {
  101.   my ( $address, $doexpand ) = @_;
  102.   die "negative address is not allowed\n"
  103.     if $address < 0;
  104.   return if $address <= $#heap;
  105.   die "heap out of range\n" if !$doexpand;
  106.   push @heap, (0)x($address-$#heap-1);
  107. }
  108. sub storeheap
  109. {
  110.   my ( $val, $addr ) = @_;
  111.   checkHeapAddress($addr,1);
  112.   $heap[$addr] = $val;
  113. }
  114. sub wsstor
  115. {
  116.   storeheap(splice @stack, 0, 2);
  117. }
  118. sub wsretr
  119. {
  120.   my $addr = shift @stack;
  121.   checkHeapAddress($addr,0);
  122.   unshift @stack, $heap[$addr];
  123. }
  124. sub wsmark
  125. {
  126.   my $label = shift;
  127.   return if exists $labels{$label}->{'ip'};
  128.   $labels{$label}->{'ip'} = $ip;
  129.   undef $skip if defined $skip && $skip->{'to'} eq $label;
  130. }
  131. sub wsjump_common(@)
  132. {
  133.   my $label = shift;
  134.   if ( exists $labels{$label}->{'ip'} )
  135.   {
  136.     $ip = $labels{$label}->{'ip'};
  137.   }
  138.   else
  139.   {
  140.     $skip = { 'to' => $label, 'from' => $ip };
  141.   }
  142. }
  143. sub wscall
  144. {
  145.   unshift @cstack, $ip;
  146.   wsjump_common(@_);
  147. }
  148. sub wsjump
  149. {
  150.   wsjump_common(@_);
  151. }
  152. sub wsjzero
  153. {
  154.   return unless 0 == shift @stack;
  155.   wsjump_common(@_);
  156. }
  157. sub wsjneg
  158. {
  159.   return unless 0 > shift @stack;
  160.   wsjump_common(@_);
  161. }
  162. sub wsret
  163. {
  164.   die "call stack is empty\n" unless @cstack;
  165.   $ip = shift @cstack;
  166. }
  167. sub wsend
  168. {
  169.   $continue = 0;
  170. }
  171. sub wsputc
  172. {
  173.   my $val = shift @stack;
  174.   my $c = chr $val;
  175.   $c =~ /[^[:print:]\s]/
  176.     and die "output non-printable character ( $val )\n";
  177.   print $c;
  178. }
  179. sub wsputi
  180. {
  181.   print shift @stack;
  182. }
  183. sub fillbuffer
  184. {
  185.   $ibuf = <>;
  186.   die "detected eof on input stream\n"
  187.     unless defined $ibuf;
  188. }
  189. sub wsgetc
  190. {
  191.   fillbuffer() if $ibuf eq '';
  192.   my $val = ord substr $ibuf, 0, 1, '';
  193.   my $addr = shift @stack;
  194.   storeheap($val, $addr);
  195. }
  196. sub wsgeti
  197. {
  198.   fillbuffer() if $ibuf eq '';
  199.   $ibuf =~ /^\s*([-]?\d+)\s*$/
  200.     or die "not integer data on input stream\n";
  201.   my $val = 0+$1;
  202.   $ibuf = '';
  203.   my $addr = shift @stack;
  204.   storeheap($val, $addr);
  205. }
  206. my %ops = (
  207.   'push'  => { 'sub' => \&wspush,  'imp' => 's',  'code' => 's',  'arg' => 'int' },
  208.   'dup'   => { 'sub' => \&wsdup,   'imp' => 's',  'code' => 'ns', 'arg' => 'void', 'stackfreq' => 1 },
  209.   'copy'  => { 'sub' => \&wscopy,  'imp' => 's',  'code' => 'ts', 'arg' => 'uint' },
  210.   'swap'  => { 'sub' => \&wsswap,  'imp' => 's',  'code' => 'nt', 'arg' => 'void', 'stackfreq' => 2 },
  211.   'pop'   => { 'sub' => \&wspop,   'imp' => 's',  'code' => 'nn', 'arg' => 'void', 'stackfreq' => 1 },
  212.   'slide' => { 'sub' => \&wsslide, 'imp' => 's',  'code' => 'tn', 'arg' => 'uint' },
  213.   'add'   => { 'sub' => \&wsadd,   'imp' => 'ts', 'code' => 'ss', 'arg' => 'void', 'stackfreq' => 2 },
  214.   'sub'   => { 'sub' => \&wssub,   'imp' => 'ts', 'code' => 'st', 'arg' => 'void', 'stackfreq' => 2 },
  215.   'mul'   => { 'sub' => \&wsmul,   'imp' => 'ts', 'code' => 'sn', 'arg' => 'void', 'stackfreq' => 2 },
  216.   'div'   => { 'sub' => \&wsdiv,   'imp' => 'ts', 'code' => 'ts', 'arg' => 'void', 'stackfreq' => 2 },
  217.   'mod'   => { 'sub' => \&wsmod,   'imp' => 'ts', 'code' => 'tt', 'arg' => 'void', 'stackfreq' => 2 },
  218.   'stor'  => { 'sub' => \&wsstor,  'imp' => 'tt', 'code' => 's',  'arg' => 'void', 'stackfreq' => 2 },
  219.   'retr'  => { 'sub' => \&wsretr,  'imp' => 'tt', 'code' => 't',  'arg' => 'void', 'stackfreq' => 1 },
  220.   'mark'  => { 'sub' => \&wsmark,  'imp' => 'n',  'code' => 'ss', 'arg' => 'label', 'dontskip' => 1 },
  221.   'call'  => { 'sub' => \&wscall,  'imp' => 'n',  'code' => 'st', 'arg' => 'label' },
  222.   'jump'  => { 'sub' => \&wsjump,  'imp' => 'n',  'code' => 'sn', 'arg' => 'label' },
  223.   'jzero' => { 'sub' => \&wsjzero, 'imp' => 'n',  'code' => 'ts', 'arg' => 'label', 'stackfreq' => 1 },
  224.   'jneg'  => { 'sub' => \&wsjneg,  'imp' => 'n',  'code' => 'tt', 'arg' => 'label', 'stackfreq' => 1 },
  225.   'ret'   => { 'sub' => \&wsret,   'imp' => 'n',  'code' => 'tn', 'arg' => 'void' },
  226.   'end'   => { 'sub' => \&wsend,   'imp' => 'n',  'code' => 'nn', 'arg' => 'void' },
  227.   'putc'  => { 'sub' => \&wsputc,  'imp' => 'tn', 'code' => 'ss', 'arg' => 'void', 'stackfreq' => 1 },
  228.   'puti'  => { 'sub' => \&wsputi,  'imp' => 'tn', 'code' => 'st', 'arg' => 'void', 'stackfreq' => 1 },
  229.   'getc'  => { 'sub' => \&wsgetc,  'imp' => 'tn', 'code' => 'ts', 'arg' => 'void', 'stackfreq' => 1 },
  230.   'geti'  => { 'sub' => \&wsgeti,  'imp' => 'tn', 'code' => 'tt', 'arg' => 'void', 'stackfreq' => 1 },
  231. );
  232. sub argcode($$$)
  233. {
  234.   my ( $arg, $sig, $arglen ) = @_;
  235.   $sig = '+' unless defined $sig;
  236.   my $nosig = '';
  237.   if ( $arg != 0 )
  238.   {
  239.     my @part = ();
  240.     my $base = 1<<63;
  241.     for ( ; $arg >= $base; $arg /= $base )
  242.     {
  243.        unshift @part, sprintf '%063b', $arg%$base;
  244.     }
  245.     $nosig = join '', ( sprintf '%b', $arg ), @part;
  246.   }
  247.   my $padding = defined $arglen && $arglen > length $nosig ?
  248.                 '0'x($arglen-length$nosig) : '';
  249.   return "$sig$padding$nosig.";
  250. }
  251. sub convert($)
  252. {
  253.   if ( $codelevel == 2 )
  254.   {
  255.     $_[0] =~ tr/+0\-1. /ssttn/d;
  256.   }
  257.   elsif ( $codelevel >= 3 )
  258.   {
  259.     $_[0] =~ tr/+0s\-1t.n /   \t\t\t\n\n/d;
  260.   }
  261. }
  262. sub compile($)
  263. {
  264.   my ( $lineno, $line ) = @{$_[0]};
  265.   $line =~ /^\s*(\w+)(\s+(([-+])?(\d+)(?:\((\d+)b\))?|(\w+)))?\s*$/
  266.     or die "invalid format at line $lineno\n";
  267.   my $istr = $1;
  268.   die "'$istr' is unknown at line $lineno\n"
  269.     if ! exists $ops{$istr};
  270.   my $ref = $ops{$istr};
  271.   my %ret = ();
  272.   my $argstr = '';
  273.   my $arglen = 0;
  274.   if ( $ref->{'arg'} eq 'void' )
  275.   {
  276.     die "no arguments allowed for '$istr' at line $lineno\n"
  277.       if defined $2;
  278.   }
  279.   elsif ( defined $5 )
  280.   {
  281.     my $arg = 0+$5;
  282.     my $sig = $4//'+';
  283.     $argstr = argcode($arg, $sig, $6);
  284.     $arglen = length $argstr;
  285.     my $ilen=$arglen-2;
  286.     $ret{'arg'} = $ref->{'arg'} eq 'label' ?
  287.                     "$sig$arg(${ilen}b)" :
  288.                     $sig eq '-' ? -$arg : $arg;
  289.     $ret{'negativeargerror'} = 1
  290.       if $ref->{'arg'} eq 'uint' && $sig eq '-';
  291.     $labels{$ret{'arg'}}->{'count'}++
  292.       if $ref->{'arg'} eq 'label';
  293.   }
  294.   else
  295.   {
  296.     die "invalid argument for '$istr' at line $lineno\n"
  297.       unless $ref->{'arg'} eq 'label';
  298.     if ( defined $7 )
  299.     {
  300.       $ret{'arg'} = $7;
  301.       $ret{'relabel'} = 1;
  302.       $labels{$ret{'arg'}}->{'relabel'} = 1;
  303.     }
  304.     else
  305.     {
  306.       $ret{'arg'} = '';
  307.       $argstr = '.';
  308.       $arglen = 1;
  309.     }
  310.     $labels{$ret{'arg'}}->{'count'}++;
  311.   }
  312.   if ( $codelevel > 0 )
  313.   {
  314.     my $code = join ' ', @$ref{qw(imp code)};
  315.     $code .= " $argstr" if $argstr ne '';
  316.     convert($code);
  317.     $ret{'code'} = $code;
  318.   }
  319.   $bytes+=$arglen+length($ref->{'imp'})+length($ref->{'code'});
  320.   @ret{qw(sub dontskip stackfreq)} = @$ref{qw(sub dontskip stackfreq)};
  321.   $ret{'line'} = $lineno;
  322.   return \%ret;
  323. }
  324. sub relabel()
  325. {
  326.   my $null_unused = !exists $labels{''};
  327.   my ( $body, $sig, $len, $lim ) = ( 0, '+', 0, 1 );
  328.   my ( $lcand, $code );
  329.   foreach my $label ( sort { $labels{$b}->{'count'} <=> $labels{$a}->{'count'} || $a cmp $b }
  330.                       grep { exists $labels{$_}->{'relabel'} } keys %labels )
  331.   {
  332.     my $newlabel;
  333.     if ( $null_unused )
  334.     {
  335.       $newlabel = '';
  336.       $code = '.';
  337.       $null_unused = 0;
  338.     }
  339.     else
  340.     {
  341.       for ( my $retry=1; $retry; )
  342.       {
  343.         $newlabel="$sig$body(${len}b)";
  344.         if ( !exists $labels{$newlabel} )
  345.         {
  346.           $retry = 0;
  347.           $code = argcode($body,$sig,$len);
  348.         }
  349.         if ( $sig eq '+' )
  350.         {
  351.           $sig = '-';
  352.         }
  353.         else
  354.         {
  355.           $sig = '+';
  356.           if ( ++$body >= $lim )
  357.           {
  358.             $body = 0;
  359.             $len++;
  360.             $lim*=2;
  361.           }
  362.         }
  363.       }
  364.     }
  365.     $labels{$label}->{'relabel'} = $newlabel;
  366.     $labels{$label}->{'code'} = $code;
  367.     $bytes += length($code)*$labels{$label}->{'count'};
  368.   }
  369.   foreach my $i ( @inst )
  370.   {
  371.     next unless exists $i->{'relabel'};
  372.     my $code = ' ' . $labels{$i->{'arg'}}->{'code'};
  373.     convert($code);
  374.     $i->{'code'} .= $code;
  375.   }
  376. }
  377. sub report($)
  378. {
  379.   my $error = shift;
  380.   my $ssize = @stack;
  381.   my $hsize = @heap;
  382.   my $msg = $error ? 'with an error' : 'normally';
  383.   relabel();
  384.   print <<_EOS_;
  385. --
  386. program ended $msg.
  387.  instructions: $inum
  388.  steps:        $step
  389.  the last ip:  $ip ( line $inst[$ip-1]->{'line'} )
  390.  src bytes:    $bytes
  391.  stack size:   $ssize (final) / $stackhwm (high water mark)
  392.  heap size:    $hsize
  393. _EOS_
  394.   print "\nlabel statistics:\n";
  395.   if ( !%labels )
  396.   {
  397.     print "no label exists\n"
  398.   }
  399.   else
  400.   {
  401.     foreach my $label ( sort { $labels{$b}->{'count'} <=> $labels{$a}->{'count'} || $a cmp $b } keys %labels )
  402.     {
  403.       print ' ',
  404.             ( $label eq '' ? '(null)' : $label ),
  405.             ( exists $labels{$label}->{'relabel'} ?
  406.                 ' relabeled to ' . (
  407.                   $labels{$label}->{'relabel'} eq '' ?
  408.                     '(null)' : $labels{$label}->{'relabel'} ) :
  409.                 '' ),
  410.              ': ', $labels{$label}->{'count'}, "\n";
  411.     }
  412.   }
  413.   print "\nthe error is shown below:\n$error\n" if $error;
  414.   if ( $codelevel > 0 )
  415.   {
  416.     print "--code--\n";
  417.     print join $codelevel<2?"\n":"", map { $_->{'code'} } @inst;
  418.     print "\n--end--\n";
  419.   }
  420. }
  421.  
  422. sub readsrc($)
  423. {
  424.   my $ssrc = shift;
  425.   my $separated = defined $ssrc;
  426.   my @lines = ();
  427.   my $ifh = \*ARGV;
  428.   if ( $separated )
  429.   {
  430.     open $ifh, '<', $ssrc
  431.       or die "failed to open source file\n";
  432.   }
  433.   my $embbedopt_end = 0;
  434.   while ( <$ifh> )
  435.   {
  436.     chomp;
  437.     if ( $_ eq $ENDMARK )
  438.     {
  439.       die "don't use '$ENDMARK' in a separated source file\n"
  440.         if $separated;
  441.       last;
  442.     }
  443.     if ( !$embbedopt_end && /^#\+opt:\s*(\w+)(=(\w+))?/ )
  444.     {
  445.       if ( $1 eq 'unlimited' && !defined $2 )
  446.       {
  447.         $unlimited = 1;
  448.       }
  449.       elsif ( $1 eq 'codelevel' && defined $3 )
  450.       {
  451.         $codelevel = 0+$3;
  452.       }
  453.       elsif ( $1 eq 'limit' && defined $3 )
  454.       {
  455.         $slimit = 0+$3;
  456.       }
  457.       else
  458.       {
  459.         warn "invalid embbed option at line $.\n";
  460.       }
  461.       next;
  462.     }
  463.     s/\s*(#.*)?$//;
  464.     next unless /\S/;
  465.     push @lines, [ $., $_ ];
  466.     $embbedopt_end = 1;
  467.   }
  468.   return @lines;
  469. }
  470.  
  471. #-- main
  472. my $usage = "Usage: $0 [-h] [-u|-l maxsteps] [-c code-level] {[merged-file] | -s srcfile [input-file]}\n";
  473. my %opts = ();
  474. getopts('hus:l:c:', \%opts);
  475.  
  476. die $usage if exists $opts{'h'};
  477. $unlimited = exists $opts{'u'};
  478. die $usage if $unlimited && exists $opts{'l'};
  479. $slimit = $opts{'l'} // $SLIMIT_DEFAULT;
  480. $codelevel = $opts{'c'} // $CLEVEL_DEFAULT;
  481.  
  482. my @srclines = readsrc($opts{'s'});
  483.  
  484. eval
  485. {
  486.   while ( $continue )
  487.   {
  488.     die "exceeded step limit\n"
  489.       if !$unlimited && $step>=$slimit;
  490.     $ip++;
  491.     my $i;
  492.     if ( $ip <= @inst )
  493.     {
  494.       $i = $inst[$ip-1];
  495.     }
  496.     else
  497.     {
  498.       if ( !@srclines )
  499.       {
  500.         my $sup;
  501.         if ( defined $skip )
  502.         {
  503.           $sup = "mark '$skip->{'to'}'";
  504.           $ip = $skip->{'from'};
  505.         }
  506.         else
  507.         {
  508.           $sup = 'end';
  509.           $ip--;
  510.         }
  511.         die "unexpected end of source before the $sup\n"
  512.       }
  513.       eval
  514.       {
  515.         $i = compile(shift @srclines);
  516.       };
  517.       if ( $@ )
  518.       {
  519.         chomp $@;
  520.         die "invalid instruction ( $@ )\n";
  521.       }
  522.       $inum++;
  523.       push @inst, $i;
  524.     }
  525.     next if defined $skip && !$i->{'dontskip'};
  526.     eval
  527.     {
  528.       die "negative argument is not allowed\n"
  529.         if $i->{'negativeargerror'};
  530.       die $i->{'stackfreq'}>1 ? "stack short\n" : "stack empty\n"
  531.         if defined $i->{'stackfreq'} && @stack < $i->{'stackfreq'};
  532.       &{$i->{'sub'}}(@$i{qw(arg)});
  533.     };
  534.     if ( $@ )
  535.     {
  536.       chomp $@;
  537.       die "runtime error ( $@ at line $i->{'line'} )\n";
  538.     }
  539.     $step++;
  540.   }
  541. };
  542. report($@);
Success #stdin #stdout 0.11s 6444KB
comments (?)
stdin
copy 
#+opt: codelevel=2
#+opt: unlimited
push 0
mark Main

  dup
  push 26
  mod
  dup
  copy 2
  push 26
  div
  swap
  sub
  
  push 82204
  swap
  mark Shift
  swap
  push 2
  div
  swap
  push 1
  add
  dup
  jneg Shift
  pop
  
  push 2
  mod
  push -32
  mul
  push 97
  add
  add
  putc
  
push 1
add
dup
push 572
sub
jneg Main
--end--
stdout
copy 
abCDEfghIjklmnOpQrstuvwxyzabcDEFghiJklmnoPqRstuvwxyzabcdEFGhijKlmnopQrStuvwxyzabcdeFGHijkLmnopqRsTuvwxyzabcdefGHIjklMnopqrStUvwxyzabcdefgHIJklmNopqrsTuVwxyzabcdefghIJKlmnOpqrstUvWxyzabcdefghiJKLmnoPqrstuVwXyzabcdefghijKLMnopQrstuvWxYzabcdefghijkLMNopqRstuvwXyZabcdefghijklMNOpqrStuvwxYzabcdefghijklmNOPqrsTuvwxyZabcdefghijklmnOPQrstUvwxyzabcdefghijklmnoPQRstuVwxyzabcdefghijklmnopQRStuvWxyzabcdefghijklmnopqRSTuvwXyzabcdefghijklmnopqrSTUvwxYzabcdefghijklmnopqrsTUVwxyZabcdefghijklmnopqrstUVWxyzabcdefghijklmnopqrstuVWXyzabcdefghijklmnopqrstuvWXYzabcdefghijklmnopqrstuvwXYZ--
program ended with an error.
 instructions: 37
 steps:        40790
 the last ip:  37 ( line 43 )
 src bytes:    200
 stack size:   1 (final) / 5 (high water mark)
 heap size:    0

label statistics:
 Main relabeled to (null): 2
 Shift relabeled to +0(0b): 2

the error is shown below:
unexpected end of source before the end

--code--
sssnnssnsnssssttstsntsttsnsstsstsnsssttstsntstssnttsstssststssssstssstttssnsntnsssnsntssstsntstssntssstntssssnsnttsnsnnssstsntsttssttsssssntssnsssttsssstntssstssstnssssstntssssnsssstsssttttssntsstnttn
--end--
https://ideone.com/cbFvao
the 12th Death-ma Colosseum https://c...content-available-to-author-only...q.jp/q/1903 WhiteSpase(200) on WSsimulator thanks to https://t...content-available-to-author-only...r.com/henkoudekimasu/status/645634064473419776
language:
Perl (perl 5.28.1)
created:
8 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!