clc-intercal 1:1.0~4pre1.-94.-2-4 / usr / share / perl5 / Language / INTERCAL / DoubleOhSeven.pm

package Language::INTERCAL::DoubleOhSeven;

# Special version of Language::INTERCAL::Numbers used for "double-oh-seven"
# registers

# This file is part of CLC-INTERCAL

# Copyright (c) 2006-2008 Claudio Calvelli, all rights reserved.

# CLC-INTERCAL is copyrighted software. However, permission to use, modify,
# and distribute it is granted provided that the conditions set out in the
# licence agreement are met. See files README and COPYING in the distribution.

use strict;
use vars qw($VERSION $PERVERSION);
($VERSION) = ($PERVERSION = "CLC-INTERCAL/Base INTERCAL/DoubleOhSeven.pm 1.-94.-2") =~ /\s(\S+)$/;

use Carp;
use Language::INTERCAL::Exporter '1.-94.-2';
use Language::INTERCAL::Splats '1.-94.-2', qw(:SP splatname);
use Language::INTERCAL::Numbers '1.-94.-2';
use Language::INTERCAL::ReadNumbers '1.-94.-2', qw(roman_type roman_name);
use Language::INTERCAL::Charset '1.-94.-2', qw(charset charset_name);
use Language::INTERCAL::ArrayIO '1.-94.-2', qw(iotype iotype_name);
use vars qw(@ISA);
@ISA = qw(Language::INTERCAL::Numbers::Spot);

my %types = (
    base => [2, \&_code_base, undef],
    charset => [0, \&_code_charset, \&_decode_charset],
    comefrom => [0, \&_code_comefrom, undef],
    crawlhorror => [1, \&_code_crawlhorror, undef],
    iotype => [0, \&_code_iotype, \&_decode_iotype],
    roman => [0, \&_code_roman, \&_decode_roman],
    splat => [1000, \&_code_splat, \&_decode_splat],
    spot => [0, undef, undef],
    symbol => [0, \&_code_symbol, \&_decode_symbol],
    zeroone => [0, \&_code_zeroone, undef],
);

sub new {
    @_ == 3 || @_ == 4
	or croak "Usage: Language::INTERCAL::DoubleOhSeven" .
		 "->new(TYPE, OBJECT [,VALUE])";
    my ($class, $type, $object, @value) = @_;
    exists $types{$type} or faint(SP_SPECIAL, "(type $type)");
    @value = ($types{$type}[0]) unless @value;
    return Language::INTERCAL::Numbers::Spot->new(@value)
	if ! defined $types{$type}[1];
    @value = &{$types{$type}[1]}($object, @value);
    # note, we don't use SUPER here, rather we rebless later
    my $num = Language::INTERCAL::Numbers::Spot->new(@value);
    $num->{doubleohseven} = {
	object => $object,
	type => $types{$type}[1],
	typename => $type,
	decode => $types{$type}[2],
    };
    bless $num, $class;
}

sub type {
    @_ == 1 or croak "Usage: DOUBLEOHSEVEN->type";
    my ($num) = @_;
    $num->{doubleohseven}{typename};
}

sub print {
    @_ == 1 or croak "Usage: DOUBLEOHSEVEN->print";
    my ($num) = @_;
    my $d = $num->{doubleohseven};
    $d->{decode} or return $num->SUPER::print;
    &{$d->{decode}}($d->{object}, $num->number);
}

sub _assign {
    @_ == 2 or croak "Usage: DOUBLEOHSEVEN->assign(VALUE)";
    my ($num, $value) = @_;
    exists $num->{doubleohseven} or faint(SP_NOSPECIAL);
    $num->{doubleohseven}{type} or faint(SP_NOSPECIAL);
    $value =
	&{$num->{doubleohseven}{type}}($num->{doubleohseven}{object}, $value);
    $num->SUPER::_assign($value);
    $num;
}

sub _get_number {
    my ($value, $translate, $splat) = @_;
    faint(SP_NOASSIGN, '(undef)', 'Not a number') if ! defined $value;
    return $value->spot->number
	if ref $value && UNIVERSAL::isa($value, 'Language::INTERCAL::Numbers');
    return $value
	if ! ref $value && defined $value && $value =~ /^\d+$/;
    if ($translate) {
	if (ref $value) {
	    my @num = ();
	    if (ref $value eq 'ARRAY') {
		@num = map { _get_number($_, $translate) } @$value;
	    } elsif (UNIVERSAL::isa($value, 'Language::INTERCAL::Arrays')) {
		@num = map { $_->spot->number } $value->as_list;
	    } else {
		faint(SP_NOASSIGN, $value, 'Not a number');
	    }
	    $value = pack('C*', @num);
	}
	my $t = &{$translate}($value);
	defined $t or faint($splat, $value);
	return $t;
    }
    faint(SP_NOASSIGN, $value, 'Not a number');
}

sub _decode {
    my ($value, $code) = @_;
    my $nv = $code->($value);
    return "?$nv" if defined $nv && $nv ne '';
    "#$value";
}

sub _code_base {
    my ($object, $value) = @_;
    $value = _get_number($value);
    $value < 2 || $value > 7
	and faint(SP_BASE, $value);
    $value;
}

sub _code_charset {
    my ($object, $value) = @_;
    _get_number($value, \&charset, SP_CHARSET);
}

sub _decode_charset {
    my ($object, $value) = @_;
    _decode($value, \&charset_name);
}

sub _code_comefrom {
    my ($object, $value) = @_;
    $value = _get_number($value);
    $value < 0 || $value > 3
	and faint(SP_NOASSIGN, $value,
		  'come from value must be between 0 and 3');
    $value;
}

sub _code_crawlhorror {
    my ($object, $value) = @_;
    $object or faint(SP_CONTEXT, 'missing grammar');
    my $c = _get_number($value);
    $c < 1 || $c > $object->num_parsers
	and faint(SP_NOASSIGN, $value, 'grammar number out of range');
    $c;
}

sub _code_iotype {
    my ($object, $value) = @_;
    _get_number($value, \&iotype, SP_IOTYPE);
}

sub _decode_iotype {
    my ($object, $value) = @_;
    _decode($value, \&iotype_name);
}

sub _code_roman {
    my ($object, $value) = @_;
    _get_number($value, \&roman_type, SP_ROMAN);
}

sub _decode_roman {
    my ($object, $value) = @_;
    _decode($value, \&roman_name);
}

sub _code_splat {
    my ($object, $value) = @_;
    _get_number($value, \&_splat_type, SP_INVSPLAT);
}

sub _splat_type {
    my ($code) = @_;
    defined splatname($code) ? $code : 1000;
}

sub _decode_splat {
    my ($object, $value) = @_;
    $value < 1000 ? $value : undef;
}

sub _code_symbol {
    my ($object, $value) = @_;
    $object or faint(SP_CONTEXT, 'symbol without grammar');
    _get_number($value, sub { $object->symboltable->find(@_) }, SP_SYMBOL);
}

sub _decode_symbol {
    my ($object, $value) = @_;
    _decode($value, sub { $object->symboltable->symbol(@_) } );
}

sub _code_zeroone {
    my ($object, $value) = @_;
    $value = _get_number($value);
    $value < 0 || $value > 1
	and faint(SP_NOASSIGN, $value, 'value must be 0 or 1');
    $value;
}

1;