mirror of
https://github.com/kanaka/mal.git
synced 2024-10-27 22:58:00 +03:00
8a19f60386
- Reorder README to have implementation list after "learning tool" bullet. - This also moves tests/ and libs/ into impls. It would be preferrable to have these directories at the top level. However, this causes difficulties with the wasm implementations which need pre-open directories and have trouble with paths starting with "../../". So in lieu of that, symlink those directories to the top-level. - Move the run_argv_test.sh script into the tests directory for general hygiene.
198 lines
3.7 KiB
Perl
198 lines
3.7 KiB
Perl
package types;
|
|
use strict;
|
|
use warnings;
|
|
|
|
use Data::Dumper;
|
|
use Exporter 'import';
|
|
our @EXPORT_OK = qw(_equal_Q thaw_key
|
|
$nil $true $false);
|
|
|
|
# General functions
|
|
|
|
sub _equal_Q {
|
|
my ($a, $b) = @_;
|
|
unless ((ref $a eq ref $b) ||
|
|
($a->isa('Mal::Sequence') && $b->isa('Mal::Sequence'))) {
|
|
return 0;
|
|
}
|
|
if ($a->isa('Mal::Sequence')) {
|
|
unless (scalar(@$a) == scalar(@$b)) {
|
|
return 0;
|
|
}
|
|
for (my $i=0; $i<scalar(@$a); $i++) {
|
|
unless (_equal_Q($a->[$i], $b->[$i])) {
|
|
return 0;
|
|
}
|
|
}
|
|
return 1;
|
|
} elsif ($a->isa('Mal::HashMap')) {
|
|
unless (scalar(keys %$a) == scalar(keys %$b)) {
|
|
return 0;
|
|
}
|
|
foreach my $k (keys %$a) {
|
|
unless (_equal_Q($a->{$k}, $b->{$k})) {
|
|
return 0;
|
|
}
|
|
}
|
|
return 1;
|
|
} else {
|
|
return $$a eq $$b;
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
|
|
# Errors/Exceptions
|
|
|
|
{
|
|
package Mal::BlankException;
|
|
sub new { my $class = shift; bless Mal::String->new("Blank Line") => $class }
|
|
}
|
|
|
|
# Superclass for all kinds of mal value
|
|
|
|
{
|
|
package Mal::Type;
|
|
}
|
|
|
|
# Scalars
|
|
|
|
{
|
|
package Mal::Scalar;
|
|
use parent -norequire, 'Mal::Type';
|
|
# Overload stringification so that its result is something
|
|
# suitable for use as a hash-map key. The important thing here is
|
|
# that strings and keywords are distinct: support for other kinds
|
|
# of scalar is a bonus.
|
|
use overload '""' => sub { my $self = shift; ref($self) . " " . $$self },
|
|
fallback => 1;
|
|
sub new { my ($class, $value) = @_; bless \$value, $class }
|
|
}
|
|
|
|
# This function converts hash-map keys back into full objects
|
|
|
|
sub thaw_key ($) {
|
|
my ($class, $value) = split(/ /, $_[0], 2);
|
|
return $class->new($value);
|
|
}
|
|
|
|
{
|
|
package Mal::Nil;
|
|
use parent -norequire, 'Mal::Scalar';
|
|
# Allow nil to be treated as an empty list or hash-map.
|
|
use overload '@{}' => sub { [] }, '%{}' => sub { {} }, fallback => 1;
|
|
sub rest { Mal::List->new([]) }
|
|
}
|
|
{
|
|
package Mal::True;
|
|
use parent -norequire, 'Mal::Scalar';
|
|
}
|
|
{
|
|
package Mal::False;
|
|
use parent -norequire, 'Mal::Scalar';
|
|
}
|
|
|
|
our $nil = Mal::Nil->new('nil');
|
|
our $true = Mal::True->new('true');
|
|
our $false = Mal::False->new('false');
|
|
|
|
|
|
{
|
|
package Mal::Integer;
|
|
use parent -norequire, 'Mal::Scalar';
|
|
}
|
|
|
|
|
|
{
|
|
package Mal::Symbol;
|
|
use parent -norequire, 'Mal::Scalar';
|
|
}
|
|
|
|
|
|
{
|
|
package Mal::String;
|
|
use parent -norequire, 'Mal::Scalar';
|
|
}
|
|
|
|
|
|
{
|
|
package Mal::Keyword;
|
|
use parent -norequire, 'Mal::Scalar';
|
|
}
|
|
|
|
|
|
# Sequences
|
|
|
|
{
|
|
package Mal::Sequence;
|
|
use parent -norequire, 'Mal::Type';
|
|
sub new { my $class = shift; bless $_[0], $class }
|
|
sub rest { my $arr = $_[0]; Mal::List->new([@$arr[1..$#$arr]]); }
|
|
sub clone { my $self = shift; ref($self)->new([@$self]) }
|
|
}
|
|
|
|
# Lists
|
|
|
|
{
|
|
package Mal::List;
|
|
use parent -norequire, 'Mal::Sequence';
|
|
}
|
|
|
|
|
|
# Vectors
|
|
|
|
{
|
|
package Mal::Vector;
|
|
use parent -norequire, 'Mal::Sequence';
|
|
}
|
|
|
|
|
|
# Hash-maps
|
|
|
|
{
|
|
package Mal::HashMap;
|
|
use parent -norequire, 'Mal::Type';
|
|
use List::Util qw(pairmap);
|
|
use Scalar::Util qw(reftype);
|
|
sub new {
|
|
my ($class, $src) = @_;
|
|
if (reftype($src) eq 'ARRAY') {
|
|
$src = {@$src};
|
|
}
|
|
return bless $src, $class;
|
|
}
|
|
sub clone { my $self = shift; ref($self)->new({%$self}) }
|
|
}
|
|
|
|
|
|
# Functions
|
|
|
|
{
|
|
package Mal::Callable;
|
|
use parent -norequire, 'Mal::Type';
|
|
sub new { my $class = shift; bless $_[0], $class }
|
|
sub clone { my $self = shift; bless sub { goto &$self }, ref($self) }
|
|
}
|
|
|
|
{
|
|
package Mal::Function;
|
|
use parent -norequire, 'Mal::Callable';
|
|
}
|
|
|
|
{
|
|
package Mal::Macro;
|
|
use parent -norequire, 'Mal::Callable';
|
|
}
|
|
|
|
|
|
# Atoms
|
|
|
|
{
|
|
package Mal::Atom;
|
|
use parent -norequire, 'Mal::Type';
|
|
sub new { my ($class, $val) = @_; bless \$val, $class }
|
|
sub clone { my $self = shift; ref($self)->new($$self) }
|
|
}
|
|
|
|
1;
|