has
stack
=> [];
has
return_stack
=> [];
sub
call {
my
$self
=
shift
;
for
my
$word
(
@_
) {
my
$function
=
$self
->dict->{
lc
$word
}
or
$self
->error(
"Undefined word: '$word'"
);
$function
->(
$self
);
}
}
sub
size {
scalar
(@{
$_
[0]->{stack}});
}
sub
push
{
my
(
$self
,
@items
) =
@_
;
push
@{
$self
->stack},
@items
;
}
sub
pop
{
my
(
$self
,
$count
) = (
@_
);
my
$stack
=
$self
->{stack};
$self
->underflow
unless
$count
<=
@$stack
;
return
splice
(
@$stack
, 0 -
$count
,
$count
);
}
sub
peek {
my
$self
=
shift
;
my
$stack
=
$self
->{stack};
map
{
my
$i
=
$_
+ 1;
$self
->underflow
unless
$i
<=
@$stack
;
my
$a
=
$stack
->[0 -
$i
];
return
$a
unless
wantarray
;
}
@_
;
}
sub
underflow {
$_
[0]->error(
"Stack underflow"
);
}
sub
error {
die
"$_[1]\n"
;
}
has
dict
=> {
'.'
=>
sub
{
my
$num
=
$_
[0]->
pop
(1);
print
"$num\n"
;
},
'.s'
=>
sub
{
my
$stack
=
$_
[0]->stack;
my
$size
=
@$stack
;
print
"<$size>"
.
join
(
''
,
map
" $_"
,
@$stack
) .
"\n"
;
},
'+'
=>
sub
{
my
(
$a
,
$b
) =
$_
[0]->
pop
(2);
$_
[0]->
push
(
$a
+
$b
);
},
'-'
=>
sub
{
my
(
$a
,
$b
) =
$_
[0]->
pop
(2);
$_
[0]->
push
(
$a
-
$b
);
},
'*'
=>
sub
{
my
(
$a
,
$b
) =
$_
[0]->
pop
(2);
$_
[0]->
push
(
$a
*
$b
);
},
'/'
=>
sub
{
my
(
$a
,
$b
) =
$_
[0]->
pop
(2);
$_
[0]->error(
"Division by zero"
)
if
$b
== 0;
$_
[0]->
push
(floor(
$a
/
$b
));
},
'/2'
=>
sub
{
my
(
$a
) =
$_
[0]->
pop
(1);
$_
[0]->
push
(floor(
$a
/ 2));
},
'mod'
=>
sub
{
my
(
$a
,
$b
) =
$_
[0]->
pop
(2);
$_
[0]->error(
"Division by zero"
)
if
$b
== 0;
$_
[0]->
push
(
$a
%
$b
);
},
'/mod'
=>
sub
{
$_
[0]->call(
qw(2dup mod -rot /)
);
},
'clearstack'
=>
sub
{
$_
[0]->{stack} = [];
},
'0sp'
=>
sub
{
$_
[0]->call(
'clearstack'
);
},
'dup'
=>
sub
{
my
(
$a
) =
$_
[0]->
pop
(1);
$_
[0]->
push
(
$a
,
$a
);
},
'swap'
=>
sub
{
$_
[0]->
push
(
reverse
$_
[0]->
pop
(2));
},
'over'
=>
sub
{
my
(
$a
,
$b
) =
$_
[0]->
pop
(2);
$_
[0]->
push
(
$a
,
$b
,
$a
);
},
'drop'
=>
sub
{
$_
[0]->
pop
(1);
},
'rot'
=>
sub
{
my
(
$a
,
$b
,
$c
) =
$_
[0]->
pop
(3);
$_
[0]->
push
(
$b
,
$c
,
$a
);
},
'pick'
=>
sub
{
$_
[0]->
push
(
scalar
$_
[0]->peek(
$_
[0]->
pop
(1)));
},
'?dup'
=>
sub
{
$_
[0]->call(
'dup'
)
if
(
$_
[0]->peek(0) != 0);
},
'-rot'
=>
sub
{
my
(
$a
,
$b
,
$c
) =
$_
[0]->
pop
(3);
$_
[0]->
push
(
$c
,
$a
,
$b
);
},
'2swap'
=>
sub
{
my
(
$a
,
$b
,
$c
,
$d
) =
$_
[0]->
pop
(4);
$_
[0]->
push
(
$c
,
$d
,
$a
,
$b
);
},
'2over'
=>
sub
{
my
(
$a
,
$b
,
$c
,
$d
) =
$_
[0]->
pop
(4);
$_
[0]->
push
(
$a
,
$b
,
$c
,
$d
,
$a
,
$b
);
},
'2dup'
=>
sub
{
my
(
$a
,
$b
) =
$_
[0]->
pop
(2);
$_
[0]->
push
(
$a
,
$b
,
$a
,
$b
);
},
'nip'
=>
sub
{
my
(
$a
,
$b
) =
$_
[0]->
pop
(2);
$_
[0]->
push
(
$b
);
},
'tuck'
=>
sub
{
my
(
$a
,
$b
) =
$_
[0]->
pop
(2);
$_
[0]->
push
(
$b
,
$a
,
$b
);
},
'abs'
=>
sub
{
$_
[0]->
push
(
abs
$_
[0]->
pop
(1));
},
'negate'
=>
sub
{
$_
[0]->
push
(0 -
$_
[0]->
pop
(1));
},
'lshift'
=>
sub
{
my
(
$a
,
$b
) =
$_
[0]->
pop
(2);
$_
[0]->
push
(
$a
<<
$b
);
},
'rshift'
=>
sub
{
my
(
$a
,
$b
) =
$_
[0]->
pop
(2);
$_
[0]->
push
(
$a
>>
$b
);
},
'arshift'
=>
sub
{
my
(
$a
,
$b
) =
$_
[0]->
pop
(2);
$_
[0]->
push
(
$a
>>
$b
);
},
'min'
=>
sub
{
my
(
$a
,
$b
) =
$_
[0]->
pop
(2);
$_
[0]->
push
(
$a
<
$b
?
$a
:
$b
);
},
'max'
=>
sub
{
my
(
$a
,
$b
) =
$_
[0]->
pop
(2);
$_
[0]->
push
(
$a
>
$b
?
$a
:
$b
);
},
'emit'
=>
sub
{
print
chr
$_
[0]->
pop
(1);
},
words
=>
sub
{
print
join
(
' '
,
sort
keys
%{
$_
[0]{dict}}) .
"\n"
;
},
};
1