From 0fea28cb1073527c855de945782711f89a47e227 Mon Sep 17 00:00:00 2001 From: Marius Gavrilescu Date: Sat, 28 Apr 2018 18:31:26 +0300 Subject: [PATCH] Use Data::Dump::Sexp instead of pretty_print --- Makefile.PL | 4 ++ README | 1 + lib/App/Scheme79asm/Compiler.pm | 65 +++++++++++++++------------------ t/Compiler.t | 10 +++-- 4 files changed, 40 insertions(+), 40 deletions(-) diff --git a/Makefile.PL b/Makefile.PL index 643e838..628f6e9 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -5,6 +5,7 @@ WriteMakefile( NAME => 'App::Scheme79asm', VERSION_FROM => 'lib/App/Scheme79asm.pm', ABSTRACT_FROM => 'lib/App/Scheme79asm.pm', + AUTHOR => 'Marius Gavrilescu ', MIN_PERL_VERSION => '5.14.0', LICENSE => 'perl', SIGN => 1, @@ -12,6 +13,9 @@ WriteMakefile( qw/Data::SExpression 0.41 List::MoreUtils 0.33/, }, + TEST_REQUIRES => { + qw/Data::Dump::Sexp 0/, + }, META_ADD => { dynamic_config => 0, resources => { diff --git a/README b/README index e690317..f7edf9d 100644 --- a/README +++ b/README @@ -43,6 +43,7 @@ DEPENDENCIES This module requires these other modules and libraries: +* Data::Dump::Sexp * Data::SExpression * List::MoreUtils diff --git a/lib/App/Scheme79asm/Compiler.pm b/lib/App/Scheme79asm/Compiler.pm index d9a420f..417707f 100644 --- a/lib/App/Scheme79asm/Compiler.pm +++ b/lib/App/Scheme79asm/Compiler.pm @@ -3,9 +3,7 @@ package App::Scheme79asm::Compiler; use 5.014000; use strict; use warnings; -use parent qw/Exporter/; -our @EXPORT_OK = qw/pretty_print/; our $VERSION = '0.005'; use Carp qw/croak/; @@ -17,6 +15,22 @@ use List::MoreUtils qw/firstidx/; our @PRIMOPS = qw/car cdr cons atom progn reverse-list/; +sub make_symbol { Data::SExpression::Symbol->new(shift) } + +# types +our $LIST = make_symbol 'LIST'; +our $SYMBOL = make_symbol 'SYMBOL'; +our $VAR = make_symbol 'VAR'; +# no need for closures +our $PROC = make_symbol 'PROC'; +our $IF = make_symbol 'IF'; +our $CALL = make_symbol 'CALL'; +# no need for quoted constants + +# primitives +our $MORE = make_symbol 'MORE'; +our $FUNCALL = make_symbol 'FUNCALL'; + BEGIN { *cons = *Data::SExpression::cons; *consp = *Data::SExpression::consp; @@ -78,27 +92,6 @@ sub position { my ($expr, $list) = @_; positionacc $expr, $list, 0 } - -sub pretty_print { - my ($expr) = @_; - if (!defined $expr) { - '()' - } elsif (scalarp $expr) { - "$expr" - } elsif (ref $expr eq 'ARRAY') { - '(' . join (' ', map { pretty_print($_) } @$expr). ')' - } else { - my $cdr = $expr->cdr; - my $car = $expr->car; - my $acc = '(' . pretty_print($car); - while (defined $cdr) { - $car = $cdr->car; - $cdr = $cdr->cdr; - $acc .= ' ' . pretty_print($car); - } - $acc . ')' - } -} # end list processing routines sub new { @@ -114,20 +107,20 @@ sub new { sub process_quoted { my ($self, $expr) = @_; if (!defined $expr) { # nil - [LIST => 0] + [$LIST => 0] } elsif (scalarp $expr) { $expr = uc $expr; if ($expr eq 'NIL') { - return [LIST => 0] + return [$LIST => 0] } if (!exists $self->{symbol_map}{$expr}) { $self->{symbol_map}{$expr} = $self->{nsymbols}; $self->{nsymbols}++; push @{$self->{symbols}}, $expr; } - [SYMBOL => $self->{symbol_map}{$expr}] + [$SYMBOL => $self->{symbol_map}{$expr}] } elsif (consp $expr) { - [LIST => $self->process_quoted($expr->cdr), $self->process_quoted($expr->car)] + [$LIST => $self->process_quoted($expr->cdr), $self->process_quoted($expr->car)] } else { croak 'argument to process_quoted is not a scalar, cons, or nil: ', Dumper($expr); } @@ -144,7 +137,7 @@ sub rest_of_funcall { if (!defined $args) { $func } else { - [MORE => $self->rest_of_funcall($func, $args->cdr), $args->car] + [$MORE => $self->rest_of_funcall($func, $args->cdr), $args->car] } } @@ -157,28 +150,28 @@ sub process_funcall { if (!defined $processed_args) { croak "Cannot call primitive $func_name with no arguments"; } - [CALL => $self->rest_of_funcall([uc $func_name, 0], $processed_args->cdr), $processed_args->car] + [$CALL => $self->rest_of_funcall([make_symbol(uc $func_name), 0], $processed_args->cdr), $processed_args->car] } else { my $final_args = append $processed_args, cons ($self->process_toplevel($func_name, $env), undef); - [CALL => $self->rest_of_funcall([FUNCALL => 0], $final_args->cdr), $final_args->car] + [$CALL => $self->rest_of_funcall([$FUNCALL => 0], $final_args->cdr), $final_args->car] } } sub process_toplevel { my ($self, $expr, $env) = @_; if (!defined $expr) { - [LIST => 0] + [$LIST => 0] } elsif (scalarp $expr) { if (looks_like_number $expr) { $self->process_quoted($expr); } elsif (uc $expr eq 'T') { - [SYMBOL => 2] + [$SYMBOL => 2] } elsif (uc $expr eq 'NIL') { - [LIST => 0] + [$LIST => 0] } else { my $position = position $expr, $env; if (defined $position) { - [VAR => -1 - $position] + [$VAR => -1 - $position] } else { croak "Variable $expr not in environment"; } @@ -191,12 +184,12 @@ sub process_toplevel { my $func_name = $expr->cdr->car; my $func_args = $expr->cdr->cdr->car; my $func_body = $expr->cdr->cdr->cdr->car; ## no critic (ProhibitLongChainsOfMethodCalls) - [PROC => $self->process_proc($func_name, $func_args, $func_body, $env)] + [$PROC => $self->process_proc($func_name, $func_args, $func_body, $env)] } elsif ($func eq 'IF') { my ($if_cond, $if_then, $if_else) = map { $self->process_toplevel($_, $env) } ($expr->cdr->car, $expr->cdr->cdr->car, $expr->cdr->cdr->cdr->car); ## no critic (ProhibitLongChainsOfMethodCalls) - [IF => [LIST => $if_else, $if_then], $if_cond] + [$IF => [$LIST => $if_else, $if_then], $if_cond] } else { $self->process_funcall($expr->car, $expr->cdr, $env) } diff --git a/t/Compiler.t b/t/Compiler.t index 11718b1..847cdb2 100644 --- a/t/Compiler.t +++ b/t/Compiler.t @@ -2,12 +2,14 @@ use strict; use warnings; +use Data::Dump::Sexp; use Test::More tests => 31; -BEGIN { use_ok('App::Scheme79asm::Compiler', qw/pretty_print/) }; + +BEGIN { use_ok('App::Scheme79asm::Compiler') }; sub is_sexp { my ($expr, $expected, $name) = @_; - is pretty_print($expr), $expected, $name; + is dump_sexp($expr), $expected, $name; } sub to_sexp { @@ -43,8 +45,8 @@ is_toplevel '(lambda append (x y) (if (atom x) y (cons (car x) (append (cdr x) y sub pp_roundtrip { my ($string) = @_; - my $pp = uc App::Scheme79asm::Compiler::pretty_print(to_sexp $string); - is $pp, uc($string), "pretty_print roundtrip $string"; + my $pp = uc dump_sexp(to_sexp $string); + is $pp, uc($string), "dump_sexp roundtrip $string"; } pp_roundtrip '()'; -- 2.39.2