From 90aca3cd4622b2d06dc92748ed723fd1ae31e96c Mon Sep 17 00:00:00 2001 From: Mirko Westermeier Date: Tue, 9 Dec 2014 20:53:46 +0100 Subject: [PATCH] removed the tracing operators again --- lib/PerLisp.pm | 58 +----------------------- lib/PerLisp/Expr/Function.pm | 2 - lib/PerLisp/Expr/List.pm | 16 +------ lib/PerLisp/Expr/Operator.pm | 1 - t/{80-autocurry.t => 70-autocurry.t} | 0 t/70-trace.t | 68 ---------------------------- 6 files changed, 3 insertions(+), 142 deletions(-) rename t/{80-autocurry.t => 70-autocurry.t} (100%) delete mode 100644 t/70-trace.t diff --git a/lib/PerLisp.pm b/lib/PerLisp.pm index bf46055..87d2c1d 100644 --- a/lib/PerLisp.pm +++ b/lib/PerLisp.pm @@ -20,12 +20,6 @@ has parser => PerLisp::Parser->new; has input => IO::Handle->new->fdopen(fileno(STDIN), 'r'); has output => IO::Handle->new->fdopen(fileno(STDOUT),'w'); -# trace log callback -has tracer => (default => sub { my $self = shift; sub { - my $str = shift; - $self->output->print($str . "\n"); -}}); - # set operators sub init { my $self = shift; @@ -110,52 +104,6 @@ sub init { }, )); - # trace operator: add a trace to functions and operators - $self->context->set(trace => PerLisp::Expr::Operator->new( - name => 'trace', - code => sub { - my ($context, @symbols) = @_; - - # lookup - my @fn_exprs = map { $context->get($_->name) } @symbols; - - # check traceability (duck typing) - for my $fn_expr (@fn_exprs) { - die $fn_expr->to_string . " isn't traceable.\n" - unless $fn_expr->can('tracer'); - } - - # activate trace - $_->tracer($self->tracer) for @fn_exprs; - - # return summary - return 'traced: ' . join ', ' => map { $_->name } @symbols; - }, - )); - - # untrace operator: remove a trace from functions and operators - $self->context->set(untrace => PerLisp::Expr::Operator->new( - name => 'untrace', - code => sub { - my ($context, @symbols) = @_; - - # lookup - my @fn_exprs = map { $context->get($_->name) } @symbols; - - # check traceability (duck typing) - for my $fn_expr (@fn_exprs) { - die $fn_expr->to_string . " isn't traceable.\n" - unless $fn_expr->can('tracer'); - } - - # deactivate trace - $_->tracer(undef) for @fn_exprs; - - # return summary - return 'untraced: ' . join ', ' => map { $_->name } @symbols; - }, - )); - # init definitions $self->eval($PerLisp::Init::definitions); @@ -190,10 +138,8 @@ sub read_eval_print_loop { # try to eval and print eval { - for my $val ($self->eval($line, $self->context)) { - my $val_str = ref($val) ? $val->to_string : $val // ''; - $self->output->print($val_str . "\n"); - } + my @values = $self->eval($line, $self->context); + $self->output->print($_->to_string . "\n") for @values; }; # catch errors diff --git a/lib/PerLisp/Expr/Function.pm b/lib/PerLisp/Expr/Function.pm index 338d4d2..48d2776 100644 --- a/lib/PerLisp/Expr/Function.pm +++ b/lib/PerLisp/Expr/Function.pm @@ -6,7 +6,6 @@ extends 'PerLisp::Expr'; has params => []; has body => (required => 1); has context => (required => 1); -has tracer => (); # a tracer code ref sub eval { my ($self, $context) = @_; @@ -78,7 +77,6 @@ sub apply { params => \@params, body => $self->body, context => $local_context, - tracer => $self->tracer, ); } diff --git a/lib/PerLisp/Expr/List.pm b/lib/PerLisp/Expr/List.pm index b97b35a..cab327c 100644 --- a/lib/PerLisp/Expr/List.pm +++ b/lib/PerLisp/Expr/List.pm @@ -34,22 +34,8 @@ sub eval { die $fn_expr->to_string . " can't be applied.\n" unless $function->can('apply'); - # call trace - my $ctrace = '(' . join(' ' => map { $_->to_string } $fn_expr, @args) . ')'; - $function->tracer->("\tCall\t$ctrace") - if $function->tracer; - # apply - my $ret_val = $function->apply($context, \@args); - - # return trace - my $ret_val_str = ref($ret_val) ? $ret_val->to_string : $ret_val // ''; - my $rtrace = $ret_val_str . " from $ctrace"; - $function->tracer->("\tReturn\t$rtrace") - if $function->tracer; - - # done - return $ret_val; + return $function->apply($context, \@args); } sub to_string { diff --git a/lib/PerLisp/Expr/Operator.pm b/lib/PerLisp/Expr/Operator.pm index 5e44240..db9e1fc 100644 --- a/lib/PerLisp/Expr/Operator.pm +++ b/lib/PerLisp/Expr/Operator.pm @@ -5,7 +5,6 @@ extends 'PerLisp::Expr'; has name => (required => 1); has code => (required => 1); -has tracer => (); # a tracer code ref sub eval { my ($self, $context) = @_; diff --git a/t/80-autocurry.t b/t/70-autocurry.t similarity index 100% rename from t/80-autocurry.t rename to t/70-autocurry.t diff --git a/t/70-trace.t b/t/70-trace.t deleted file mode 100644 index 59c3a6a..0000000 --- a/t/70-trace.t +++ /dev/null @@ -1,68 +0,0 @@ -#!/usr/bin/env perl - -use strict; -use warnings; - -use Test::More tests => 13; - -use PerLisp; -use FindBin '$Bin'; - -my $pl = PerLisp->new->init; - -my @traced; - -$pl->tracer(sub { push @traced, shift }); - -$pl->eval(' - (define (fib n) - (cond - (= n 0) 1 - (= n 1) 1 - (+ (fib (- n 1)) (fib (- n 2))))) -'); - -# no trace -is($pl->eval('(fib 0)')->to_simple, 1, 'right fib(0) value'); -is($pl->eval('(fib 1)')->to_simple, 1, 'right fib(1) value'); -is($pl->eval('(fib 2)')->to_simple, 2, 'right fib(4) value'); -is(scalar @traced, 0, 'no trace'); - -# multitrace -is($pl->eval('(trace + fib)'), 'traced: +, fib', 'trace on'); -is($pl->eval('(fib 2)')->to_simple, 2, 'right traced fib(2) value'); -is_deeply(\@traced, [ - "\tCall\t(fib 2)", - "\tCall\t(+ (fib (- n 1)) (fib (- n 2)))", - "\tCall\t(fib (- n 1))", - "\tReturn\t1 from (fib (- n 1))", - "\tCall\t(fib (- n 2))", - "\tReturn\t1 from (fib (- n 2))", - "\tReturn\t2 from (+ (fib (- n 1)) (fib (- n 2)))", - "\tReturn\t2 from (fib 2)", -], 'right fib(2) and plus trace'); - -# untrace -@traced = (); -is($pl->eval('(untrace +)'), 'untraced: +', 'plus trace off'); -is($pl->eval('(fib 3)')->to_simple, 3, 'right traced fib(3) value'); -is_deeply(\@traced, [ - "\tCall\t(fib 3)", - "\tCall\t(fib (- n 1))", - "\tCall\t(fib (- n 1))", - "\tReturn\t1 from (fib (- n 1))", - "\tCall\t(fib (- n 2))", - "\tReturn\t1 from (fib (- n 2))", - "\tReturn\t2 from (fib (- n 1))", - "\tCall\t(fib (- n 2))", - "\tReturn\t1 from (fib (- n 2))", - "\tReturn\t3 from (fib 3)", -], 'right fib(3) trace'); - -# no trace again -@traced = (); -is($pl->eval('(untrace fib)'), 'untraced: fib', 'fib trace off'); -is($pl->eval('(fib 9)')->to_simple, 55, 'right fib(9) value'); -is(scalar @traced, 0, 'no trace'); - -__END__