perl/core.pm

   1 package core;
   2 use strict;
   3 use warnings FATAL => qw(all);
   4 use Exporter 'import';
   5 our @EXPORT_OK = qw($core_ns);
   6
   7 use types qw(_sequential_Q _equal_Q $nil $true $false _list_Q);
   8 use reader qw(read_str);
   9 use printer qw(_pr_str);
  10
  11 use Data::Dumper;
  12
  13 # String functions
  14
  15 sub pr_str {
  16     return String->new(join(" ", map {_pr_str($_, 1)} @{$_[0]}));
  17 }
  18
  19 sub str {
  20     return String->new(join("", map {_pr_str($_, 0)} @{$_[0]}));
  21 }
  22
  23 sub prn {
  24     print join(" ", map {_pr_str($_, 1)} @{$_[0]}) . "\n";
  25     return $nil
  26 }
  27
  28 sub println {
  29     print join(" ", map {_pr_str($_, 0)} @{$_[0]}) . "\n";
  30     return $nil
  31 }
  32
  33 sub slurp {
  34     my ($fname) = ${$_[0]};
  35     open my $F, '<', $fname or die "error opening '$fname'";
  36     my $data = do { local $/; <$F> };
  37     String->new($data)
  38 }
  39
  40
  41 # List functions
  42
  43 sub cons {
  44     my ($a, $b) = @_;
  45     my @new_arr = @{[$a]};
  46     push @new_arr, @$b;
  47     List->new(\@new_arr);
  48 }
  49
  50 sub concat {
  51     if (scalar(@_) == 0) { return List->new([]); }
  52     my ($a) = shift;
  53     my @new_arr = @{$a};
  54     map { push @new_arr, @$_ } @_;
  55     List->new(\@new_arr);
  56 }
  57
  58 sub nth { my ($seq,$i) = @_; return scalar(@$seq) > $i ? $seq->[$i] : $nil; }
  59
  60 sub first { my ($seq) = @_; return scalar(@$seq) > 0 ? $seq->[0] : $nil; }
  61
  62 sub rest { return $_[0]->rest(); }
  63
  64
  65
  66 our $core_ns = {
  67     '=' =>  sub { _equal_Q($_[0][0], $_[0][1]) ? $true : $false },
  68
  69     'pr-str' =>  sub { pr_str($_[0]) },
  70     'str' =>     sub { str($_[0]) },
  71     'prn' =>     sub { prn($_[0]) },
  72     'println' => sub { println($_[0]) },
  73     'read-string' => sub { read_str(${$_[0][0]}) },
  74     'slurp' =>   sub { slurp($_[0][0]) },
  75     '<' =>  sub { ${$_[0][0]} < ${$_[0][1]} ? $true : $false },
  76     '<=' => sub { ${$_[0][0]} <= ${$_[0][1]} ? $true : $false },
  77     '>' =>  sub { ${$_[0][0]} > ${$_[0][1]} ? $true : $false },
  78     '>=' => sub { ${$_[0][0]} >= ${$_[0][1]} ? $true : $false },
  79     '+' =>  sub { Integer->new(${$_[0][0]} + ${$_[0][1]})},
  80     '-' =>  sub { Integer->new(${$_[0][0]} - ${$_[0][1]})},
  81     '*' =>  sub { Integer->new(${$_[0][0]} * ${$_[0][1]})},
  82     '/' =>  sub { Integer->new(${$_[0][0]} / ${$_[0][1]})},
  83
  84     'list'  => sub { $_[0] },
  85     'list?' => sub { _list_Q($_[0][0]) ? $true : $false },
  86
  87     'nth' => sub { nth($_[0][0], ${$_[0][1]}) },
  88     'first' => sub { first($_[0][0]) },
  89     'rest' => sub { rest($_[0][0]) },
  90     'cons' => sub { cons($_[0][0], $_[0][1]) },
  91     'concat' => sub { concat(@{$_[0]}) },
  92     'empty?' => sub { scalar(@{$_[0][0]}) == 0 ? $true : $false },
  93     'count' => sub { Integer->new(scalar(@{$_[0][0]})) },
  94 };
  95
  96 1;