perl/types.pm

   1 package types;
   2 use strict;
   3 use warnings FATAL => qw(all);
   4 use feature qw(switch);
   5 use Exporter 'import';
   6 our @EXPORT_OK = qw(_sequential_Q _equal_Q
   7                     $nil $true $false
   8                     _symbol_Q _nil_Q _true_Q _false_Q _list_Q
   9                     _hash_map _hash_map_Q _assoc_BANG _dissoc_BANG);
  10
  11 use Data::Dumper;
  12
  13 # General functions
  14
  15 sub _sequential_Q {
  16     return _list_Q($_[0]) || _vector_Q($_[0])
  17 }
  18
  19 sub _equal_Q {
  20     my ($a, $b) = @_;
  21     my ($ota, $otb) = (ref $a, ref $b);
  22     if (!(($ota eq $otb) || (_sequential_Q($a) && _sequential_Q($b)))) {
  23         return 0;
  24     }
  25     given (ref $a) {
  26         when (/^Symbol/) {
  27             return $$a eq $$b;
  28         }
  29         when (/^List/ || /^Vector/) {
  30             if (! scalar(@$a) == scalar(@$b)) {
  31                 return 0;
  32             }
  33             for (my $i=0; $i<scalar(@$a); $i++) {
  34                 if (! _equal_Q($a->[$i], $b->[$i])) {
  35                     return 0;
  36                 }
  37             }
  38             return 1;
  39         }
  40         default {
  41             return $$a eq $$b;
  42         }
  43     }
  44     return 0;
  45 }
  46
  47 # Scalars
  48
  49 {
  50     package Nil;
  51     sub new { my $class = shift; my $s = 'nil'; bless \$s => $class }
  52 }
  53 {
  54     package True;
  55     sub new { my $class = shift; my $s = 'true'; bless \$s => $class }
  56 }
  57 {
  58     package False;
  59     sub new { my $class = shift; my $s = 'false'; bless \$s => $class }
  60 }
  61
  62 our $nil =   Nil->new();
  63 our $true =  True->new();
  64 our $false = False->new();
  65
  66 sub _nil_Q   { return $_[0] eq $nil }
  67 sub _true_Q  { return $_[0] eq $true }
  68 sub _false_Q { return $_[0] eq $false }
  69
  70
  71 {
  72     package Integer;
  73     sub new  { my $class = shift; bless \$_[0] => $class }
  74 }
  75
  76
  77 {
  78     package Symbol;
  79     sub new  { my $class = shift; bless \$_[0] => $class }
  80 }
  81
  82 sub _symbol_Q { (ref $_[0]) =~ /^Symbol/ }
  83
  84
  85 {
  86     package String;
  87     sub new  { my $class = shift; bless \$_[0] => $class }
  88 }
  89
  90
  91 # Lists
  92
  93 {
  94     package List;
  95     sub new  { my $class = shift; bless $_[0], $class }
  96     sub rest { my @arr = @{$_[0]}; List->new([@arr[1..$#arr]]); }
  97     sub slice { my @arr = @{$_[0]}; List->new([@arr[$_[1]..$_[2]]]); }
  98 }
  99
 100 sub _list_Q { (ref $_[0]) =~ /^List/ }
 101
 102
 103 # Vectors
 104
 105 {
 106     package Vector;
 107     sub new  { my $class = shift; bless $_[0], $class }
 108     sub rest { my @arr = @{$_[0]}; List->new([@arr[1..$#arr]]); }
 109     sub slice { my @arr = @{$_[0]}; List->new([@arr[$_[1]..$_[2]]]); }
 110 }
 111
 112 sub _vector_Q { (ref $_[0]) =~ /^Vector/ }
 113
 114
 115 # Hash Maps
 116
 117 {
 118     package HashMap;
 119     sub new  { my $class = shift; bless $_[0], $class }
 120 }
 121
 122 sub _hash_map {
 123     my $hsh = {};
 124     return _assoc_BANG($hsh, @_);
 125 }
 126
 127 sub _assoc_BANG {
 128     my $hsh = shift;
 129     my @lst = @_;
 130     for(my $i=0; $i<scalar(@lst); $i+=2) {
 131         my $str = $lst[$i];
 132         $hsh->{$$str} = $lst[$i+1];
 133     }
 134     return HashMap->new($hsh);
 135 }
 136
 137 sub _dissoc_BANG {
 138     my $hsh = shift;
 139     my @lst = @_;
 140     for(my $i=0; $i<scalar(@lst); $i++) {
 141         my $str = $lst[$i];
 142         delete $hsh->{$$str};
 143     }
 144     return HashMap->new($hsh);
 145 }
 146
 147 sub _hash_map_Q { (ref $_[0]) =~ /^HashMap/ }
 148
 149
 150 # Functions
 151
 152 {
 153     package Function;
 154     sub new  {
 155         my $class = shift;
 156         my ($eval, $ast, $env, $params) = @_;
 157         bless {'eval'=>$eval,
 158                'ast'=>$ast,
 159                'env'=>$env,
 160                'params'=>$params,
 161                'ismacro'=>0}, $class
 162     }
 163     sub gen_env {
 164         my $self = $_[0];
 165         return Env->new($self->{env}, $self->{params}, $_[1]);
 166     }
 167     sub apply {
 168         my $self = $_[0];
 169         return &{ $self->{eval} }($self->{ast}, gen_env($self, $_[1]));
 170     }
 171 }
 172
 173 1;